├── .circleci └── config.yml ├── .gitignore ├── .hindent.yaml ├── CHANGELOG.rst ├── HLint.hs ├── LICENSE.Apache-2.0 ├── LICENSE.BSD3 ├── Makefile ├── README.md ├── Setup.hs ├── benchmarks ├── Main.hs └── Validation.hs ├── docs ├── .gitignore ├── Makefile ├── README.md └── source │ ├── conf.py │ ├── index.rst │ └── tutorial │ ├── Introduction.lhs │ ├── LICENSE │ ├── package.yaml │ └── tutorial.cabal ├── examples ├── InputObject.hs └── UnionExample.hs ├── graphql-api.cabal ├── graphql-wai ├── graphql-wai.cabal ├── package.yaml ├── src │ └── GraphQL │ │ └── Wai.hs └── tests │ └── Tests.hs ├── package.yaml ├── scripts ├── build-image ├── hpc-ratchet ├── image-tag └── lint ├── src ├── GraphQL.hs └── GraphQL │ ├── API.hs │ ├── Internal │ ├── API.hs │ ├── API │ │ └── Enum.hs │ ├── Arbitrary.hs │ ├── Execution.hs │ ├── Name.hs │ ├── OrderedMap.hs │ ├── Output.hs │ ├── Resolver.hs │ ├── Schema.hs │ ├── Syntax │ │ ├── AST.hs │ │ ├── Encoder.hs │ │ ├── Parser.hs │ │ └── Tokens.hs │ ├── Validation.hs │ ├── Value.hs │ └── Value │ │ ├── FromValue.hs │ │ └── ToValue.hs │ ├── Resolver.hs │ └── Value.hs ├── stack-8.0.yaml ├── stack-8.2.yaml └── tests ├── ASTSpec.hs ├── EndToEndSpec.hs ├── EnumTests.hs ├── ExampleSchema.hs ├── Main.hs ├── OrderedMapSpec.hs ├── ResolverSpec.hs ├── SchemaSpec.hs ├── Spec.hs ├── ValidationSpec.hs ├── ValueSpec.hs └── doctests └── Main.hs /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build-8.0: 4 | docker: 5 | # GHC 8.0.2 is the lowest supported compiler version. 6 | - image: fpco/stack-build:lts-9.21 7 | steps: 8 | - checkout 9 | - restore_cache: 10 | keys: 11 | - stack-ghc-{{ checksum "stack-8.0.yaml" }} 12 | - restore_cache: 13 | keys: 14 | - stack-deps-{{ checksum "package.yaml" }} 15 | - run: 16 | name: Set up Stack 17 | command: STACK_YAML=stack-8.0.yaml stack setup --no-terminal --no-reinstall 18 | - save_cache: 19 | key: stack-ghc-{{ checksum "stack-8.0.yaml" }} 20 | paths: 21 | - /root/.stack 22 | - run: 23 | name: Install dependencies 24 | command: STACK_YAML=stack-8.0.yaml stack build --skip-ghc-check --no-terminal --test --only-dependencies 25 | - save_cache: 26 | key: stack-deps-{{ checksum "package.yaml" }} 27 | paths: 28 | - /root/.stack 29 | - .stack-work 30 | - run: 31 | # Build with --pedantic here to avoid introducing warnings. We 32 | # *don't* build with -Werror on Hackage as that is strongly 33 | # discouraged. 34 | name: Tests 35 | command: STACK_YAML=stack-8.0.yaml stack test --skip-ghc-check --no-terminal --pedantic 36 | build-8.2: 37 | docker: 38 | # Latest stackage LTS for GHC 8.2 at time of writing 39 | - image: fpco/stack-build:lts-10.4 40 | steps: 41 | - checkout 42 | - restore_cache: 43 | keys: 44 | - stack-ghc-{{ checksum "stack-8.2.yaml" }} 45 | - restore_cache: 46 | keys: 47 | - stack-deps-{{ checksum "package.yaml" }} 48 | - run: 49 | name: Set up Stack 50 | command: STACK_YAML=stack-8.2.yaml stack setup --no-terminal --no-reinstall 51 | - save_cache: 52 | key: stack-ghc-{{ checksum "stack-8.2.yaml" }} 53 | paths: 54 | - /root/.stack 55 | - run: 56 | name: Install dependencies 57 | command: STACK_YAML=stack-8.2.yaml stack build --skip-ghc-check --no-terminal --test --only-dependencies 58 | - save_cache: 59 | key: stack-deps-{{ checksum "package.yaml" }} 60 | paths: 61 | - /root/.stack 62 | - .stack-work 63 | - run: 64 | # Build with --pedantic here to avoid introducing warnings. We 65 | # *don't* build with -Werror on Hackage as that is strongly 66 | # discouraged. 67 | # 68 | # Build with --coverage to ratchet our test coverage. 69 | name: Tests 70 | command: STACK_YAML=stack-8.2.yaml stack test --skip-ghc-check --no-terminal --pedantic --coverage 71 | - store_artifacts: 72 | path: /root/project/.stack-work/install/x86_64-linux/lts-10.4/8.2.2/hpc 73 | - run: 74 | # There's probably a clever way of separating this from the 8.2 build, 75 | # but I can't be bothered figuring that out right now. 76 | # Thus, tacking the coverage check onto one of the builds, 77 | # arbitrarily picking 8.2 because I feel like it. 78 | name: Coverage 79 | command: STACK_YAML=stack-8.2.yaml ./scripts/hpc-ratchet 80 | 81 | workflows: 82 | version: 2 83 | build_all_versions: 84 | jobs: 85 | - build-8.0 86 | - build-8.2 87 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 2 2 | line-length: 80 3 | force-trailing-newline: true 4 | -------------------------------------------------------------------------------- /CHANGELOG.rst: -------------------------------------------------------------------------------- 1 | ===================== 2 | graphql-api changelog 3 | ===================== 4 | 5 | 0.4.0 (YYYY-MM-DD) 6 | ================== 7 | 8 | * Schemas that have empty field lists or empty unions will fail much earlier 9 | 10 | 0.3.0 (2018-02-08) 11 | ================== 12 | 13 | Breaking changes 14 | ---------------- 15 | 16 | * ``Enum`` handlers are now monadic (see `#118`_) 17 | * You must use protolude 0.2.1 or later 18 | * ``Defaultable`` must now be imported from ``GraphQL.API``, rather than ``GraphQL.Resolver``, 19 | this moves ``GraphQL.API`` closer to being sufficient for API definition. (see `#149`_) 20 | * ``GraphQL.Value.ToValue`` and ``GraphQL.Value.FromValue`` modules have been removed. 21 | Import ``ToValue(..)`` and ``FromValue(..)`` from ``GraphQL.Value`` directly. 22 | 23 | Improvements 24 | ------------ 25 | 26 | * Now support GHC 8.2 as well as 8.0.2 and later 27 | * Added support for anonymous queries (thanks `@sunwukonga`_) 28 | 29 | .. _`#118`: https://github.com/jml/graphql-api/issues/118 30 | .. _`#149`: https://github.com/haskell-graphql/graphql-api/issues/149 31 | .. _`@sunwukonga`: https://github.com/sunwukonga 32 | 33 | v0.2.0 (2017-10-12) 34 | =================== 35 | 36 | * Make ``Name`` an overloaded string that panics if an invalid name is 37 | provided. 38 | * Correctly descend into the type parameter of a ``Maybe``. See https://github.com/jml/graphql-api/issues/119. 39 | This is a backwards-incompatible change. 40 | 41 | A common update would be having to ``fmap pure callback`` instead of just ``callback`` 42 | for ``Maybe`` handlers. 43 | 44 | 45 | v0.1.0 (2017-01-30) 46 | =================== 47 | 48 | No code changes. 49 | 50 | * Remove ``-Werror`` in order to upload to hackage 51 | 52 | 53 | v0.1.0 (2017-01-29) 54 | =================== 55 | 56 | Initial release, support basic handling of GraphQL queries. 57 | -------------------------------------------------------------------------------- /HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.HLint 2 | import "hint" HLint.Generalise 3 | 4 | ignore "Use fmap" 5 | ignore "Redundant do" 6 | ignore "Use =<<" 7 | -------------------------------------------------------------------------------- /LICENSE.Apache-2.0: -------------------------------------------------------------------------------- 1 | Apache License 2 | 3 | Version 2.0, January 2004 4 | 5 | http://www.apache.org/licenses/ 6 | 7 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 8 | 9 | 1. Definitions. 10 | 11 | "License" shall mean the terms and conditions for use, reproduction, and 12 | distribution as defined by Sections 1 through 9 of this document. 13 | 14 | "Licensor" shall mean the copyright owner or entity authorized by the 15 | copyright owner that is granting the License. 16 | 17 | "Legal Entity" shall mean the union of the acting entity and all other 18 | entities that control, are controlled by, or are under common control with 19 | that entity. For the purposes of this definition, "control" means (i) the 20 | power, direct or indirect, to cause the direction or management of such 21 | entity, whether by contract or otherwise, or (ii) ownership of fifty percent 22 | (50%) or more of the outstanding shares, or (iii) beneficial ownership of such 23 | entity. 24 | 25 | "You" (or "Your") shall mean an individual or Legal Entity exercising 26 | permissions granted by this License. 27 | 28 | "Source" form shall mean the preferred form for making modifications, 29 | including but not limited to software source code, documentation source, and 30 | configuration files. 31 | 32 | "Object" form shall mean any form resulting from mechanical transformation or 33 | translation of a Source form, including but not limited to compiled object 34 | code, generated documentation, and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or Object form, 37 | made available under the License, as indicated by a copyright notice that is 38 | included in or attached to the work (an example is provided in the Appendix 39 | below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object form, that 42 | is based on (or derived from) the Work and for which the editorial revisions, 43 | annotations, elaborations, or other modifications represent, as a whole, an 44 | original work of authorship. For the purposes of this License, Derivative 45 | Works shall not include works that remain separable from, or merely link (or 46 | bind by name) to the interfaces of, the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including the original 49 | version of the Work and any modifications or additions to that Work or 50 | Derivative Works thereof, that is intentionally submitted to Licensor for 51 | inclusion in the Work by the copyright owner or by an individual or Legal 52 | Entity authorized to submit on behalf of the copyright owner. For the purposes 53 | of this definition, "submitted" means any form of electronic, verbal, or 54 | written communication sent to the Licensor or its representatives, including 55 | but not limited to communication on electronic mailing lists, source code 56 | control systems, and issue tracking systems that are managed by, or on behalf 57 | of, the Licensor for the purpose of discussing and improving the Work, but 58 | excluding communication that is conspicuously marked or otherwise designated 59 | in writing by the copyright owner as "Not a Contribution." 60 | 61 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf 62 | of whom a Contribution has been received by Licensor and subsequently 63 | incorporated within the Work. 64 | 65 | 2. Grant of Copyright License. Subject to the terms and conditions of this 66 | License, each Contributor hereby grants to You a perpetual, worldwide, 67 | non-exclusive, no-charge, royalty-free, irrevocable copyright license to 68 | reproduce, prepare Derivative Works of, publicly display, publicly perform, 69 | sublicense, and distribute the Work and such Derivative Works in Source or 70 | Object form. 71 | 72 | 3. Grant of Patent License. Subject to the terms and conditions of this 73 | License, each Contributor hereby grants to You a perpetual, worldwide, 74 | non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this 75 | section) patent license to make, have made, use, offer to sell, sell, import, 76 | and otherwise transfer the Work, where such license applies only to those 77 | patent claims licensable by such Contributor that are necessarily infringed by 78 | their Contribution(s) alone or by combination of their Contribution(s) with 79 | the Work to which such Contribution(s) was submitted. If You institute patent 80 | litigation against any entity (including a cross-claim or counterclaim in a 81 | lawsuit) alleging that the Work or a Contribution incorporated within the Work 82 | constitutes direct or contributory patent infringement, then any patent 83 | licenses granted to You under this License for that Work shall terminate as of 84 | the date such litigation is filed. 85 | 86 | 4. Redistribution. You may reproduce and distribute copies of the Work or 87 | Derivative Works thereof in any medium, with or without modifications, and in 88 | Source or Object form, provided that You meet the following conditions: 89 | 90 | You must give any other recipients of the Work or Derivative Works a copy of 91 | this License; and 92 | 93 | You must cause any modified files to carry prominent notices stating that You 94 | changed the files; and 95 | 96 | You must retain, in the Source form of any Derivative Works that You 97 | distribute, all copyright, patent, trademark, and attribution notices from the 98 | Source form of the Work, excluding those notices that do not pertain to any 99 | part of the Derivative Works; and 100 | 101 | If the Work includes a "NOTICE" text file as part of its distribution, then 102 | any Derivative Works that You distribute must include a readable copy of the 103 | attribution notices contained within such NOTICE file, excluding those notices 104 | that do not pertain to any part of the Derivative Works, in at least one of 105 | the following places: within a NOTICE text file distributed as part of the 106 | Derivative Works; within the Source form or documentation, if provided along 107 | with the Derivative Works; or, within a display generated by the Derivative 108 | Works, if and wherever such third-party notices normally appear. The contents 109 | of the NOTICE file are for informational purposes only and do not modify the 110 | License. You may add Your own attribution notices within Derivative Works that 111 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 112 | provided that such additional attribution notices cannot be construed as 113 | modifying the License. 114 | 115 | You may add Your own copyright statement to Your modifications and may provide 116 | additional or different license terms and conditions for use, reproduction, or 117 | distribution of Your modifications, or for any such Derivative Works as a 118 | whole, provided Your use, reproduction, and distribution of the Work otherwise 119 | complies with the conditions stated in this License. 120 | 121 | 5. Submission of Contributions. Unless You explicitly state otherwise, any 122 | Contribution intentionally submitted for inclusion in the Work by You to the 123 | Licensor shall be under the terms and conditions of this License, without any 124 | additional terms or conditions. Notwithstanding the above, nothing herein 125 | shall supersede or modify the terms of any separate license agreement you may 126 | have executed with Licensor regarding such Contributions. 127 | 128 | 6. Trademarks. This License does not grant permission to use the trade names, 129 | trademarks, service marks, or product names of the Licensor, except as 130 | required for reasonable and customary use in describing the origin of the Work 131 | and reproducing the content of the NOTICE file. 132 | 133 | 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in 134 | writing, Licensor provides the Work (and each Contributor provides its 135 | Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 136 | KIND, either express or implied, including, without limitation, any warranties 137 | or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 138 | PARTICULAR PURPOSE. You are solely responsible for determining the 139 | appropriateness of using or redistributing the Work and assume any risks 140 | associated with Your exercise of permissions under this License. 141 | 142 | 8. Limitation of Liability. In no event and under no legal theory, whether in 143 | tort (including negligence), contract, or otherwise, unless required by 144 | applicable law (such as deliberate and grossly negligent acts) or agreed to in 145 | writing, shall any Contributor be liable to You for damages, including any 146 | direct, indirect, special, incidental, or consequential damages of any 147 | character arising as a result of this License or out of the use or inability 148 | to use the Work (including but not limited to damages for loss of goodwill, 149 | work stoppage, computer failure or malfunction, or any and all other 150 | commercial damages or losses), even if such Contributor has been advised of 151 | the possibility of such damages. 152 | 153 | 9. Accepting Warranty or Additional Liability. While redistributing the Work 154 | or Derivative Works thereof, You may choose to offer, and charge a fee for, 155 | acceptance of support, warranty, indemnity, or other liability obligations 156 | and/or rights consistent with this License. However, in accepting such 157 | obligations, You may act only on Your own behalf and on Your sole 158 | responsibility, not on behalf of any other Contributor, and only if You agree 159 | to indemnify, defend, and hold each Contributor harmless for any liability 160 | incurred by, or claims asserted against, such Contributor by reason of your 161 | accepting any such warranty or additional liability. 162 | 163 | END OF TERMS AND CONDITIONS 164 | -------------------------------------------------------------------------------- /LICENSE.BSD3: -------------------------------------------------------------------------------- 1 | Copyright J. Daniel Navarro (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of J. Daniel Navarro nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: check clean docs format lint 2 | 3 | check: 4 | stack test --fast 5 | 6 | clean: 7 | stack clean 8 | 9 | docs: 10 | stack haddock 11 | 12 | format: 13 | ./scripts/hindent-everything 14 | 15 | lint: 16 | hlint -q . 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # graphql-api 2 | 3 | [![CircleCI](https://circleci.com/gh/jml/graphql-api.svg?style=shield)](https://circleci.com/gh/jml/graphql-api) 4 | [![Documentation Status](https://readthedocs.org/projects/haskell-graphql-api/badge/?version=latest)](http://haskell-graphql-api.readthedocs.io/en/latest/?badge=latest) 5 | 6 | `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. 7 | 8 | The library provides type combinators to create a GraphQL schema, and functions to parse and evaluate queries against the schema. 9 | 10 | You can find the latest release on [hackage](https://hackage.haskell.org/package/graphql-api). 11 | 12 | We implement the [GraphQL specification](https://facebook.github.io/graphql/) as best as we can in Haskell. We figure they know what they're doing. Even if an alternative API or behaviour looks nicer, we will defer to the spec. 13 | 14 | ## Tutorial 15 | 16 | A simple graphql-api tutorial can be read at [readthedocs.io](http://haskell-graphql-api.readthedocs.io/en/latest/tutorial/Introduction.html). 17 | 18 | To follow along and get your hands dirty, clone this repository, enter the `graphql-api` root directory, and run: 19 | ``` 20 | stack repl tutorial 21 | ``` 22 | 23 | ## Example 24 | 25 | Say we have a simple GraphQL schema like: 26 | 27 | ```graphql 28 | type Hello { 29 | greeting(who: String!): String! 30 | } 31 | ``` 32 | 33 | which defines a single top-level type `Hello` which contains a single field, `greeting`, that takes a single, required argument `who`. 34 | 35 | We can define this schema in Haskell and implement a simple handler like so: 36 | 37 | ```haskell 38 | {-# LANGUAGE OverloadedStrings #-} 39 | {-# LANGUAGE TypeApplications #-} 40 | {-# LANGUAGE TypeOperators #-} 41 | 42 | import Data.Text (Text) 43 | import Data.Monoid ((<>)) 44 | 45 | import GraphQL 46 | import GraphQL.API 47 | import GraphQL.Resolver (Handler, returns) 48 | 49 | type Hello = Object "Hello" '[] 50 | '[ Argument "who" Text :> Field "greeting" Text ] 51 | 52 | hello :: Handler IO Hello 53 | hello = pure (\who -> returns ("Hello " <> who)) 54 | 55 | run :: Text -> IO Response 56 | run = interpretAnonymousQuery @Hello hello 57 | ``` 58 | 59 | We require GHC 8.0.2 or later for features like the `@Hello` type application, and for certain bug fixes. We also support GHC 8.2. 60 | 61 | With the code above we can now run a query: 62 | 63 | ```haskell 64 | run "{ greeting(who: \"mort\") }" 65 | ``` 66 | 67 | Which will produce the following GraphQL response: 68 | 69 | ```json 70 | { 71 | "data": { 72 | "greeting": "Hello mort" 73 | } 74 | } 75 | ``` 76 | 77 | ## Status 78 | 79 | Our current goal is to gather feedback. We have learned a lot about GraphQL in the course of making this library, but we don't know what a good GraphQL library looks like in Haskell. Please [let us know](https://github.com/jml/graphql-api/issues/new) what you think. We won't mind if you file a bug telling us how good the library is. 80 | 81 | Because we're still learning, we make **no** guarantees about API stability, or anything at all really. 82 | 83 | We are tracking open problems, missing features & wishlist items in [GitHub's issue tracker](https://github.com/jml/graphql-api/issues). 84 | 85 | ## Roadmap 86 | 87 | * Near future: 88 | - Better error messages (this is really important to us) 89 | - Full support for recursive data types 90 | - Close off loose ends in current implementation & gather feedback 91 | * Medium future: 92 | - Full schema validation 93 | - Schema introspection 94 | - Stabilize public API 95 | * Long term: 96 | - Derive client implementations from types 97 | - Allow users to implement their own type combinators 98 | 99 | ## References 100 | 101 | * [GraphQL Specification](http://facebook.github.io/graphql/) ([source](https://github.com/facebook/graphql)) 102 | * [GraphQL tutorial](http://graphql.org/learn/) 103 | * [GraphQL AST in Haskell](http://hackage.haskell.org/package/graphql-0.3/docs/Data-GraphQL-AST.html) 104 | 105 | ## Copyright 106 | 107 | All files Copyright (c) 2016-2017 Thomas E. Hunger & Jonathan M. Lange, except: 108 | 109 | * src/GraphQL/Internal/Syntax/AST.hs 110 | * src/GraphQL/Internal/Syntax/Encoder.hs 111 | * src/GraphQL/Internal/Syntax/Parser.hs 112 | 113 | for which see LICENSE.BSD3 in this repository. 114 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /benchmarks/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Protolude 4 | 5 | import Criterion.Main (bgroup, defaultMain) 6 | import qualified Validation 7 | 8 | 9 | main :: IO () 10 | main = do 11 | defaultMain [ bgroup "GraphQL API" Validation.benchmarks 12 | ] 13 | -------------------------------------------------------------------------------- /benchmarks/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Validation (benchmarks) where 3 | 4 | import Protolude 5 | 6 | import Criterion (Benchmark, bench, nf) 7 | import GraphQL.Internal.Validation (findDuplicates) 8 | 9 | 10 | benchmarks :: [Benchmark] 11 | benchmarks = 12 | [ bench "findDuplicates" (nf findDuplicates exampleData) 13 | ] 14 | where 15 | exampleData :: [Int] 16 | exampleData = [2, 8, 9, 8, 1, 7, 5, 0, 1, 3, 5, 4] 17 | -------------------------------------------------------------------------------- /docs/.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | source/tutorial/dist 3 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line. 5 | SPHINXOPTS = 6 | SPHINXBUILD = sphinx-build 7 | PAPER = 8 | BUILDDIR = build 9 | 10 | # User-friendly check for sphinx-build 11 | ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1) 12 | $(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/) 13 | endif 14 | 15 | # Internal variables. 16 | PAPEROPT_a4 = -D latex_paper_size=a4 17 | PAPEROPT_letter = -D latex_paper_size=letter 18 | ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source 19 | # the i18n builder cannot share the environment and doctrees with the others 20 | I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source 21 | 22 | .PHONY: help 23 | help: 24 | @echo "Please use \`make ' where is one of" 25 | @echo " html to make standalone HTML files" 26 | @echo " dirhtml to make HTML files named index.html in directories" 27 | @echo " singlehtml to make a single large HTML file" 28 | @echo " pickle to make pickle files" 29 | @echo " json to make JSON files" 30 | @echo " htmlhelp to make HTML files and a HTML help project" 31 | @echo " qthelp to make HTML files and a qthelp project" 32 | @echo " applehelp to make an Apple Help Book" 33 | @echo " devhelp to make HTML files and a Devhelp project" 34 | @echo " epub to make an epub" 35 | @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" 36 | @echo " latexpdf to make LaTeX files and run them through pdflatex" 37 | @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx" 38 | @echo " text to make text files" 39 | @echo " man to make manual pages" 40 | @echo " texinfo to make Texinfo files" 41 | @echo " info to make Texinfo files and run them through makeinfo" 42 | @echo " gettext to make PO message catalogs" 43 | @echo " changes to make an overview of all changed/added/deprecated items" 44 | @echo " xml to make Docutils-native XML files" 45 | @echo " pseudoxml to make pseudoxml-XML files for display purposes" 46 | @echo " linkcheck to check all external links for integrity" 47 | @echo " doctest to run all doctests embedded in the documentation (if enabled)" 48 | @echo " coverage to run coverage check of the documentation (if enabled)" 49 | 50 | .PHONY: clean 51 | clean: 52 | rm -rf $(BUILDDIR)/* 53 | 54 | .PHONY: html 55 | html: 56 | $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html 57 | @echo 58 | @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." 59 | 60 | .PHONY: dirhtml 61 | dirhtml: 62 | $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml 63 | @echo 64 | @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." 65 | 66 | .PHONY: singlehtml 67 | singlehtml: 68 | $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml 69 | @echo 70 | @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." 71 | 72 | .PHONY: pickle 73 | pickle: 74 | $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle 75 | @echo 76 | @echo "Build finished; now you can process the pickle files." 77 | 78 | .PHONY: json 79 | json: 80 | $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json 81 | @echo 82 | @echo "Build finished; now you can process the JSON files." 83 | 84 | .PHONY: htmlhelp 85 | htmlhelp: 86 | $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp 87 | @echo 88 | @echo "Build finished; now you can run HTML Help Workshop with the" \ 89 | ".hhp project file in $(BUILDDIR)/htmlhelp." 90 | 91 | .PHONY: qthelp 92 | qthelp: 93 | $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp 94 | @echo 95 | @echo "Build finished; now you can run "qcollectiongenerator" with the" \ 96 | ".qhcp project file in $(BUILDDIR)/qthelp, like this:" 97 | @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/GraphQLAPItutorial.qhcp" 98 | @echo "To view the help file:" 99 | @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/GraphQLAPItutorial.qhc" 100 | 101 | .PHONY: applehelp 102 | applehelp: 103 | $(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp 104 | @echo 105 | @echo "Build finished. The help book is in $(BUILDDIR)/applehelp." 106 | @echo "N.B. You won't be able to view it unless you put it in" \ 107 | "~/Library/Documentation/Help or install it in your application" \ 108 | "bundle." 109 | 110 | .PHONY: devhelp 111 | devhelp: 112 | $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp 113 | @echo 114 | @echo "Build finished." 115 | @echo "To view the help file:" 116 | @echo "# mkdir -p $$HOME/.local/share/devhelp/GraphQLAPItutorial" 117 | @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/GraphQLAPItutorial" 118 | @echo "# devhelp" 119 | 120 | .PHONY: epub 121 | epub: 122 | $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub 123 | @echo 124 | @echo "Build finished. The epub file is in $(BUILDDIR)/epub." 125 | 126 | .PHONY: latex 127 | latex: 128 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 129 | @echo 130 | @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." 131 | @echo "Run \`make' in that directory to run these through (pdf)latex" \ 132 | "(use \`make latexpdf' here to do that automatically)." 133 | 134 | .PHONY: latexpdf 135 | latexpdf: 136 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 137 | @echo "Running LaTeX files through pdflatex..." 138 | $(MAKE) -C $(BUILDDIR)/latex all-pdf 139 | @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." 140 | 141 | .PHONY: latexpdfja 142 | latexpdfja: 143 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 144 | @echo "Running LaTeX files through platex and dvipdfmx..." 145 | $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja 146 | @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." 147 | 148 | .PHONY: text 149 | text: 150 | $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text 151 | @echo 152 | @echo "Build finished. The text files are in $(BUILDDIR)/text." 153 | 154 | .PHONY: man 155 | man: 156 | $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man 157 | @echo 158 | @echo "Build finished. The manual pages are in $(BUILDDIR)/man." 159 | 160 | .PHONY: texinfo 161 | texinfo: 162 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo 163 | @echo 164 | @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." 165 | @echo "Run \`make' in that directory to run these through makeinfo" \ 166 | "(use \`make info' here to do that automatically)." 167 | 168 | .PHONY: info 169 | info: 170 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo 171 | @echo "Running Texinfo files through makeinfo..." 172 | make -C $(BUILDDIR)/texinfo info 173 | @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." 174 | 175 | .PHONY: gettext 176 | gettext: 177 | $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale 178 | @echo 179 | @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." 180 | 181 | .PHONY: changes 182 | changes: 183 | $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes 184 | @echo 185 | @echo "The overview file is in $(BUILDDIR)/changes." 186 | 187 | .PHONY: linkcheck 188 | linkcheck: 189 | $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck 190 | @echo 191 | @echo "Link check complete; look for any errors in the above output " \ 192 | "or in $(BUILDDIR)/linkcheck/output.txt." 193 | 194 | .PHONY: doctest 195 | doctest: 196 | $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest 197 | @echo "Testing of doctests in the sources finished, look at the " \ 198 | "results in $(BUILDDIR)/doctest/output.txt." 199 | 200 | .PHONY: coverage 201 | coverage: 202 | $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage 203 | @echo "Testing of coverage in the sources finished, look at the " \ 204 | "results in $(BUILDDIR)/coverage/python.txt." 205 | 206 | .PHONY: xml 207 | xml: 208 | $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml 209 | @echo 210 | @echo "Build finished. The XML files are in $(BUILDDIR)/xml." 211 | 212 | .PHONY: pseudoxml 213 | pseudoxml: 214 | $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml 215 | @echo 216 | @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml." 217 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Documentation 2 | 3 | The docs are written in literal Haskell (`.lhs` ending) and 4 | [Sphinx](http://www.sphinx-doc.org/). To build the docs install sphinx 5 | and recommonmark. To make sure the tutorial still compiles go to 6 | `./source/tutorial` and run `cabal build`. 7 | -------------------------------------------------------------------------------- /docs/source/conf.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | # 3 | # GraphQL API tutorial documentation build configuration file, created by 4 | # sphinx-quickstart on Fri Dec 16 13:29:48 2016. 5 | # 6 | # This file is execfile()d with the current directory set to its 7 | # containing dir. 8 | # 9 | # Note that not all possible configuration values are present in this 10 | # autogenerated file. 11 | # 12 | # All configuration values have a default; values that are commented out 13 | # serve to show the default. 14 | 15 | import sys 16 | import os 17 | from recommonmark.parser import CommonMarkParser 18 | 19 | # If extensions (or modules to document with autodoc) are in another directory, 20 | # add these directories to sys.path here. If the directory is relative to the 21 | # documentation root, use os.path.abspath to make it absolute, like shown here. 22 | #sys.path.insert(0, os.path.abspath('.')) 23 | 24 | # -- General configuration ------------------------------------------------ 25 | 26 | # If your documentation needs a minimal Sphinx version, state it here. 27 | #needs_sphinx = '1.0' 28 | 29 | # Add any Sphinx extension module names here, as strings. They can be 30 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 31 | # ones. 32 | extensions = [] 33 | 34 | # Add any paths that contain templates here, relative to this directory. 35 | templates_path = ['_templates'] 36 | 37 | # The suffix(es) of source filenames. 38 | # You can specify multiple suffix as a list of string: 39 | source_suffix = ['.rst', '.md', '.lhs'] 40 | 41 | # The encoding of source files. 42 | #source_encoding = 'utf-8-sig' 43 | 44 | # The master toctree document. 45 | master_doc = 'index' 46 | 47 | # General information about the project. 48 | project = u'GraphQL API tutorial' 49 | copyright = u'2016, teh, jml' 50 | author = u'teh, jml' 51 | 52 | # The version info for the project you're documenting, acts as replacement for 53 | # |version| and |release|, also used in various other places throughout the 54 | # built documents. 55 | # 56 | # The short X.Y version. 57 | version = u'0.1' 58 | # The full version, including alpha/beta/rc tags. 59 | release = u'0.1' 60 | 61 | # The language for content autogenerated by Sphinx. Refer to documentation 62 | # for a list of supported languages. 63 | # 64 | # This is also used if you do content translation via gettext catalogs. 65 | # Usually you set "language" from the command line for these cases. 66 | language = None 67 | 68 | # There are two options for replacing |today|: either, you set today to some 69 | # non-false value, then it is used: 70 | #today = '' 71 | # Else, today_fmt is used as the format for a strftime call. 72 | #today_fmt = '%B %d, %Y' 73 | 74 | # List of patterns, relative to source directory, that match files and 75 | # directories to ignore when looking for source files. 76 | exclude_patterns = [] 77 | 78 | # The reST default role (used for this markup: `text`) to use for all 79 | # documents. 80 | #default_role = None 81 | 82 | # If true, '()' will be appended to :func: etc. cross-reference text. 83 | #add_function_parentheses = True 84 | 85 | # If true, the current module name will be prepended to all description 86 | # unit titles (such as .. function::). 87 | #add_module_names = True 88 | 89 | # If true, sectionauthor and moduleauthor directives will be shown in the 90 | # output. They are ignored by default. 91 | #show_authors = False 92 | 93 | # The name of the Pygments (syntax highlighting) style to use. 94 | pygments_style = 'sphinx' 95 | 96 | # A list of ignored prefixes for module index sorting. 97 | #modindex_common_prefix = [] 98 | 99 | # If true, keep warnings as "system message" paragraphs in the built documents. 100 | #keep_warnings = False 101 | 102 | # If true, `todo` and `todoList` produce output, else they produce nothing. 103 | todo_include_todos = False 104 | 105 | 106 | # -- Options for HTML output ---------------------------------------------- 107 | 108 | # The theme to use for HTML and HTML Help pages. See the documentation for 109 | # a list of builtin themes. 110 | html_theme = 'classic' 111 | 112 | # Theme options are theme-specific and customize the look and feel of a theme 113 | # further. For a list of options available for each theme, see the 114 | # documentation. 115 | #html_theme_options = {} 116 | 117 | # Add any paths that contain custom themes here, relative to this directory. 118 | #html_theme_path = [] 119 | 120 | # The name for this set of Sphinx documents. If None, it defaults to 121 | # " v documentation". 122 | #html_title = None 123 | 124 | # A shorter title for the navigation bar. Default is the same as html_title. 125 | #html_short_title = None 126 | 127 | # The name of an image file (relative to this directory) to place at the top 128 | # of the sidebar. 129 | #html_logo = None 130 | 131 | # The name of an image file (relative to this directory) to use as a favicon of 132 | # the docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 133 | # pixels large. 134 | #html_favicon = None 135 | 136 | # Add any paths that contain custom static files (such as style sheets) here, 137 | # relative to this directory. They are copied after the builtin static files, 138 | # so a file named "default.css" will overwrite the builtin "default.css". 139 | html_static_path = ['_static'] 140 | 141 | # Add any extra paths that contain custom files (such as robots.txt or 142 | # .htaccess) here, relative to this directory. These files are copied 143 | # directly to the root of the documentation. 144 | #html_extra_path = [] 145 | 146 | # If not '', a 'Last updated on:' timestamp is inserted at every page bottom, 147 | # using the given strftime format. 148 | #html_last_updated_fmt = '%b %d, %Y' 149 | 150 | # If true, SmartyPants will be used to convert quotes and dashes to 151 | # typographically correct entities. 152 | #html_use_smartypants = True 153 | 154 | # Custom sidebar templates, maps document names to template names. 155 | #html_sidebars = {} 156 | 157 | # Additional templates that should be rendered to pages, maps page names to 158 | # template names. 159 | #html_additional_pages = {} 160 | 161 | # If false, no module index is generated. 162 | #html_domain_indices = True 163 | 164 | # If false, no index is generated. 165 | #html_use_index = True 166 | 167 | # If true, the index is split into individual pages for each letter. 168 | #html_split_index = False 169 | 170 | # If true, links to the reST sources are added to the pages. 171 | #html_show_sourcelink = True 172 | 173 | # If true, "Created using Sphinx" is shown in the HTML footer. Default is True. 174 | #html_show_sphinx = True 175 | 176 | # If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. 177 | #html_show_copyright = True 178 | 179 | # If true, an OpenSearch description file will be output, and all pages will 180 | # contain a tag referring to it. The value of this option must be the 181 | # base URL from which the finished HTML is served. 182 | #html_use_opensearch = '' 183 | 184 | # This is the file name suffix for HTML files (e.g. ".xhtml"). 185 | #html_file_suffix = None 186 | 187 | # Language to be used for generating the HTML full-text search index. 188 | # Sphinx supports the following languages: 189 | # 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja' 190 | # 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr' 191 | #html_search_language = 'en' 192 | 193 | # A dictionary with options for the search language support, empty by default. 194 | # Now only 'ja' uses this config value 195 | #html_search_options = {'type': 'default'} 196 | 197 | # The name of a javascript file (relative to the configuration directory) that 198 | # implements a search results scorer. If empty, the default will be used. 199 | #html_search_scorer = 'scorer.js' 200 | 201 | # Output file base name for HTML help builder. 202 | htmlhelp_basename = 'GraphQLAPItutorialdoc' 203 | 204 | # -- Options for LaTeX output --------------------------------------------- 205 | 206 | latex_elements = { 207 | # The paper size ('letterpaper' or 'a4paper'). 208 | #'papersize': 'letterpaper', 209 | 210 | # The font size ('10pt', '11pt' or '12pt'). 211 | #'pointsize': '10pt', 212 | 213 | # Additional stuff for the LaTeX preamble. 214 | #'preamble': '', 215 | 216 | # Latex figure (float) alignment 217 | #'figure_align': 'htbp', 218 | } 219 | 220 | # Grouping the document tree into LaTeX files. List of tuples 221 | # (source start file, target name, title, 222 | # author, documentclass [howto, manual, or own class]). 223 | latex_documents = [ 224 | (master_doc, 'GraphQLAPItutorial.tex', u'GraphQL API tutorial Documentation', 225 | u'teh, jml', 'manual'), 226 | ] 227 | 228 | # The name of an image file (relative to this directory) to place at the top of 229 | # the title page. 230 | #latex_logo = None 231 | 232 | # For "manual" documents, if this is true, then toplevel headings are parts, 233 | # not chapters. 234 | #latex_use_parts = False 235 | 236 | # If true, show page references after internal links. 237 | #latex_show_pagerefs = False 238 | 239 | # If true, show URL addresses after external links. 240 | #latex_show_urls = False 241 | 242 | # Documents to append as an appendix to all manuals. 243 | #latex_appendices = [] 244 | 245 | # If false, no module index is generated. 246 | #latex_domain_indices = True 247 | 248 | 249 | # -- Options for manual page output --------------------------------------- 250 | 251 | # One entry per manual page. List of tuples 252 | # (source start file, name, description, authors, manual section). 253 | man_pages = [ 254 | (master_doc, 'graphqlapitutorial', u'GraphQL API tutorial Documentation', 255 | [author], 1) 256 | ] 257 | 258 | # If true, show URL addresses after external links. 259 | #man_show_urls = False 260 | 261 | 262 | # -- Options for Texinfo output ------------------------------------------- 263 | 264 | # Grouping the document tree into Texinfo files. List of tuples 265 | # (source start file, target name, title, author, 266 | # dir menu entry, description, category) 267 | texinfo_documents = [ 268 | (master_doc, 'GraphQLAPItutorial', u'GraphQL API tutorial Documentation', 269 | author, 'GraphQLAPItutorial', 'One line description of project.', 270 | 'Miscellaneous'), 271 | ] 272 | 273 | # Documents to append as an appendix to all manuals. 274 | #texinfo_appendices = [] 275 | 276 | # If false, no module index is generated. 277 | #texinfo_domain_indices = True 278 | 279 | # How to display URL addresses: 'footnote', 'no', or 'inline'. 280 | #texinfo_show_urls = 'footnote' 281 | 282 | # If true, do not generate a @detailmenu in the "Top" node's menu. 283 | #texinfo_no_detailmenu = False 284 | 285 | 286 | source_parsers = { 287 | '.md': CommonMarkParser, 288 | '.lhs': CommonMarkParser, 289 | } 290 | -------------------------------------------------------------------------------- /docs/source/index.rst: -------------------------------------------------------------------------------- 1 | .. GraphQL API tutorial documentation master file, created by 2 | sphinx-quickstart on Fri Dec 16 13:29:48 2016. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Welcome to GraphQL API tutorial's documentation! 7 | ================================================ 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 1 13 | 14 | tutorial/Introduction.lhs 15 | 16 | 17 | Indices and tables 18 | ================== 19 | 20 | * :ref:`genindex` 21 | * :ref:`modindex` 22 | * :ref:`search` 23 | -------------------------------------------------------------------------------- /docs/source/tutorial/Introduction.lhs: -------------------------------------------------------------------------------- 1 | # Defining GraphQL type APIs 2 | 3 | First some imports: 4 | 5 | ``` haskell 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | 11 | module Introduction where 12 | 13 | import Protolude 14 | 15 | import System.Random 16 | 17 | import GraphQL 18 | import GraphQL.API (Object, Field, Argument, (:>), Union) 19 | import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns, handlerError) 20 | ``` 21 | 22 | ## A simple GraphQL service 23 | 24 | A [GraphQL](http://graphql.org/) service is made up of two things: 25 | 26 | 1. A schema that defines the service 27 | 2. Some code that implements the service's behavior 28 | 29 | We're going to build a very simple service that says hello to 30 | people. Our GraphQL schema for this looks like: 31 | 32 | ```graphql 33 | type Hello { 34 | greeting(who: String!): String! 35 | } 36 | ``` 37 | 38 | Which means we have base type, an _object_ called `Hello`, which has a single 39 | _field_ `greeting`, which takes a non-nullable `String` called `who` and 40 | returns a `String`. 41 | 42 | Note that all the types here are GraphQL types, not Haskell types. `String` 43 | here is a GraphQL `String`, not a Haskell one. 44 | 45 | And we want to be able to send queries that look like: 46 | 47 | ```graphql 48 | { 49 | greeting(who: "world") 50 | } 51 | ``` 52 | 53 | And get responses like: 54 | 55 | ```json 56 | { 57 | "data": { 58 | "greeting": "Hello world!" 59 | } 60 | } 61 | ``` 62 | 63 | ### Defining the schema 64 | 65 | Here's how we would define the schema in Haskell: 66 | 67 | ```haskell 68 | type Hello = Object "Hello" '[] 69 | '[ Argument "who" Text :> Field "greeting" Text 70 | ] 71 | ``` 72 | 73 | Breaking this down, we define a new Haskell type `Hello`, which is a GraphQL 74 | object (also named `"Hello"`) that implements no interfaces (hence `'[]`). It 75 | has one field, called `"greeting"` which returns some `Text` and takes a 76 | single named argument `"who"`, which is also `Text`. 77 | 78 | Note that the GraphQL `String` from above got translated into a Haskell 79 | `Text`. 80 | 81 | There are some noteworthy differences between this schema and the GraphQL 82 | schema: 83 | 84 | * The GraphQL schema requires a special annotation to say that a value cannot 85 | be null, `!`. In Haskell, we instead assume that nothing can be null. 86 | * In the GraphQL schema, the argument appears *after* the field name. In 87 | Haskell, it appears *before*. 88 | * In Haskell, we name the top-level type twice, once on left hand side of the 89 | type definition and once on the right. 90 | 91 | ### Implementing the handlers 92 | 93 | Once we have the schema, we need to define the corresponding handlers, which 94 | are `Handler` values. 95 | 96 | Here's a `Handler` for `Hello`: 97 | 98 | ```haskell 99 | hello :: Handler IO Hello 100 | hello = pure greeting 101 | where 102 | greeting who = returns ("Hello " <> who <> "!") 103 | ``` 104 | 105 | The type signature, `Handler IO Hello` shows that it's a `Handler` for 106 | `Hello`, and that it runs in the `IO` monad. (Note: nothing about this example 107 | code requires the `IO` monad, it's just a monad that lots of people has heard 108 | of.) 109 | 110 | The implementation looks slightly weird, but it's weird for good reasons. 111 | 112 | The first layer of the handler, `pure greeting`, produces the `Hello` object. 113 | The `pure` might seem redundant here, but making this step monadic allows us 114 | to run actions in the base monad. 115 | 116 | The second layer of the handler, the implementation of `greeting`, produces 117 | the value of the `greeting` field. It is monadic so that it will only be 118 | executed when the field was requested. It uses the 'returns' function to 119 | return the value for the field in the monad (technically, the Applicative 120 | context which is OK because a Monad is Applicative). 121 | 122 | Each field handler is a separate monadic action so we only perform the side 123 | effects for fields present in the query. 124 | 125 | This handler is in `Identity` because it doesn't do anything particularly 126 | monadic. It could be in `IO` or `STM` or `ExceptT Text IO` or whatever you 127 | would like. 128 | 129 | ### Errors in handlers 130 | 131 | It's possible that a handler will encounter an error as well (for example, the argument might be looked up in a database and the user might specify a non-existent user). To help support GraphQL-compliant errors, a handler can use the `handlerError` function with the error text. 132 | 133 | Here's a modified `Handler` for `Hello`: 134 | 135 | ```haskell 136 | helloFancy :: Handler IO Hello 137 | helloFancy = pure greeting 138 | where 139 | greeting who = if who == "" 140 | then handlerError "I need to know your name!" 141 | else returns ("Hello " <> who <> "!") 142 | ``` 143 | 144 | ### Running queries 145 | 146 | Defining a service isn't much point unless you can query. Here's how: 147 | 148 | ```haskell 149 | queryHello :: IO Response 150 | queryHello = interpretAnonymousQuery @Hello hello "{ greeting(who: \"mort\") }" 151 | ``` 152 | 153 | The actual `Response` type is fairly verbose, so we're most likely to turn it 154 | into JSON: 155 | 156 | ``` 157 | λ Aeson.encode <$> queryHello 158 | "{\"greeting\":\"Hello mort!\"}" 159 | ``` 160 | 161 | ## Combining field handlers with :<> 162 | 163 | How do we define an object with more than one field? 164 | 165 | Let's implement a simple calculator that can add and subtract integers. First, 166 | the schema: 167 | 168 | ```graphql 169 | type Calculator { 170 | add(a: Int!, b: Int!): Int!, 171 | sub(a: Int!, b: Int!): Int!, 172 | } 173 | ``` 174 | 175 | Here, `Calculator` is an object with two fields: `add` and `sub`. 176 | 177 | And now the Haskell version: 178 | 179 | ``` haskell 180 | type Calculator = Object "Calculator" '[] 181 | '[ Argument "a" Int32 :> Argument "b" Int32 :> Field "add" Int32 182 | , Argument "a" Int32 :> Argument "b" Int32 :> Field "subtract" Int32 183 | ] 184 | ``` 185 | 186 | So far, this is the same as our `Hello` example. 187 | 188 | And its handler: 189 | 190 | ```haskell 191 | calculator :: Handler IO Calculator 192 | calculator = pure (add :<> subtract') 193 | where 194 | add a b = returns (a + b) 195 | subtract' a b = returns (a - b) 196 | ``` 197 | 198 | This handler introduces a new operator, `:<>` (pronounced "birdface"), which 199 | is used to compose two existing handlers into a new handler. It's inspired by 200 | the operator for monoids, `<>`. 201 | 202 | Note that we use `returns` for each individual handler. 203 | 204 | ## Nesting Objects 205 | 206 | How do we define objects made up other objects? 207 | 208 | One of the great things in GraphQL is that objects can be used as types for 209 | fields. Take this classic GraphQL schema as an example: 210 | 211 | ```graphql 212 | type Query { 213 | me: User! 214 | } 215 | 216 | type User { 217 | name: Text! 218 | } 219 | ``` 220 | 221 | We would query this schema with something like: 222 | 223 | ```graphql 224 | { 225 | me { 226 | name 227 | } 228 | } 229 | ``` 230 | 231 | Which would produce output like: 232 | 233 | ```json 234 | { 235 | "data": { 236 | "me": { 237 | "name": "Mort" 238 | } 239 | } 240 | } 241 | ``` 242 | 243 | The Haskell type for this schema looks like: 244 | 245 | ```haskell 246 | type User = Object "User" '[] '[Field "name" Text] 247 | type Query = Object "Query" '[] '[Field "me" User] 248 | ``` 249 | 250 | Note that `Query` refers to the type `User` when it defines the field `me`. 251 | 252 | We write nested handlers the same way we write the top-level handler: 253 | 254 | ```haskell 255 | user :: Handler IO User 256 | user = pure name 257 | where 258 | name = returns "Mort" 259 | 260 | query :: Handler IO Query 261 | query = pure user 262 | ``` 263 | 264 | And that's it. 265 | 266 | ## Unions 267 | 268 | GraphQL has [support for union 269 | types](http://graphql.org/learn/schema/#union-types). These require special 270 | treatment in Haskell. 271 | 272 | Let's define a union, first in GraphQL: 273 | 274 | ```graphql 275 | union UserOrCalculator = User | Calculator 276 | ``` 277 | 278 | And now in Haskell: 279 | 280 | ```haskell 281 | type UserOrCalculator = Union "UserOrCalculator" '[User, Calculator] 282 | ``` 283 | 284 | And let's define a very simple top-level object that uses `UserOrCalculator`: 285 | 286 | ```haskell 287 | type UnionQuery = Object "UnionQuery" '[] '[Field "union" UserOrCalculator] 288 | ``` 289 | 290 | and a handler that randomly returns either a user or a calculator: 291 | 292 | ```haskell 293 | unionQuery :: Handler IO UnionQuery 294 | unionQuery = do 295 | returnUser <- randomIO 296 | if returnUser 297 | then pure (unionValue @User user) 298 | else pure (unionValue @Calculator calculator) 299 | ``` 300 | 301 | The important thing here is that we have to wrap the actual objects we return 302 | using `unionValue`. 303 | 304 | Note that while `unionValue` looks a bit like `unsafeCoerce` by forcing one 305 | type to become another type, it's actually type-safe because we use a 306 | *type-index* to pick the correct type from the union. Using e.g. `unionValue 307 | @HelloWorld handler` will not compile because `HelloWorld` is not in the 308 | union. 309 | 310 | ## Where next? 311 | 312 | We have an 313 | [examples](https://github.com/jml/graphql-api/tree/master/tests/Examples) 314 | directory showing full code examples. 315 | 316 | We also have a fair number of [end-to-end 317 | tests](https://github.com/jml/graphql-api/tree/master/tests/EndToEndTests.hs) 318 | based on an [example 319 | schema](https://github.com/jml/graphql-api/tree/master/tests/ExampleSchema.hs) 320 | that you might find interesting. 321 | 322 | If you want to try the examples in this tutorial you can run: 323 | 324 | ```bash 325 | stack repl tutorial 326 | ``` 327 | -------------------------------------------------------------------------------- /docs/source/tutorial/LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-graphql/graphql-api/8ced344485cd638cee50eeb6b653baecea359406/docs/source/tutorial/LICENSE -------------------------------------------------------------------------------- /docs/source/tutorial/package.yaml: -------------------------------------------------------------------------------- 1 | name: tutorial 2 | version: 0.0.1 3 | synopsis: GraphQL library tutorial 4 | license: Apache 5 | license-file: LICENSE 6 | maintainer: tehunger@gmail.com, Jonathan M. Lange 7 | 8 | ghc-options: -Wall -pgmL markdown-unlit 9 | 10 | default-extensions: 11 | - NoImplicitPrelude 12 | 13 | library: 14 | exposed-modules: 15 | - Introduction 16 | dependencies: 17 | - base >= 4.9 && < 5 18 | - protolude 19 | - graphql-api 20 | - random 21 | - markdown-unlit >= 0.4 22 | - aeson 23 | -------------------------------------------------------------------------------- /docs/source/tutorial/tutorial.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.20.0. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: b3da6c729f0fa19c9ad82cb7e45f616850463bcc1654b9cd4797e34f6685ebd8 6 | 7 | name: tutorial 8 | version: 0.0.1 9 | synopsis: GraphQL library tutorial 10 | license: Apache 11 | license-file: LICENSE 12 | maintainer: tehunger@gmail.com, Jonathan M. Lange 13 | build-type: Simple 14 | cabal-version: >= 1.10 15 | 16 | library 17 | default-extensions: NoImplicitPrelude 18 | exposed-modules: 19 | Introduction 20 | other-modules: 21 | Paths_tutorial 22 | build-depends: 23 | aeson 24 | , base >=4.9 && <5 25 | , graphql-api 26 | , markdown-unlit >=0.4 27 | , protolude 28 | , random 29 | default-language: Haskell2010 30 | ghc-options: -Wall -pgmL markdown-unlit 31 | -------------------------------------------------------------------------------- /examples/InputObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | -- | Demonstrate input object usage. 6 | module Main (main) where 7 | 8 | import Protolude hiding (Enum) 9 | 10 | import qualified Data.Aeson as Aeson 11 | 12 | import GraphQL 13 | import GraphQL.API 14 | import GraphQL.Resolver (Handler, returns) 15 | import GraphQL.Value (FromValue, toValue) 16 | 17 | data DogStuff = DogStuff { _toy :: Text, _likesTreats :: Bool } deriving (Show, Generic) 18 | instance FromValue DogStuff 19 | instance HasAnnotatedInputType DogStuff 20 | instance Defaultable DogStuff where 21 | -- TODO defaultFor takes a Name which makes sense, but what's the 22 | -- name for an input object? 23 | defaultFor _ = Just (DogStuff "shoe" False) 24 | 25 | type Query = Object "Query" '[] 26 | '[ Argument "dogStuff" DogStuff :> Field "description" Text ] 27 | 28 | root :: Handler IO Query 29 | root = pure description 30 | 31 | description :: DogStuff -> Handler IO Text 32 | description (DogStuff toy likesTreats) 33 | | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy 34 | | otherwise = returns $ "their favorite toy is a " <> toy 35 | 36 | -- | Show input object usage 37 | -- 38 | -- >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }" 39 | -- >>> putStrLn $ encode $ toValue response 40 | -- {"data":{"description":"likes treats and their favorite toy is a bone"}} 41 | -- 42 | -- >>> response <- example "{ description }" 43 | -- >>> putStrLn $ encode $ toValue response 44 | -- {"data":{"description":"their favorite toy is a shoe"}} 45 | example :: Text -> IO Response 46 | example = interpretAnonymousQuery @Query root 47 | 48 | 49 | main :: IO () 50 | main = do 51 | response <- example "{ description(dogStuff: {_toy: \"bone\", _likesTreats: true}) }" 52 | putStrLn $ Aeson.encode $ toValue response 53 | response' <- example "{ description }" 54 | putStrLn $ Aeson.encode $ toValue response' 55 | -------------------------------------------------------------------------------- /examples/UnionExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module Main (main) where 3 | 4 | import Protolude 5 | 6 | import qualified Data.Aeson as Aeson 7 | import GraphQL.API (Field, List, Object, Union) 8 | import GraphQL (interpretAnonymousQuery) 9 | import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns) 10 | import GraphQL.Value (ToValue(..)) 11 | 12 | -- Slightly reduced example from the spec 13 | type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32] 14 | type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32] 15 | 16 | type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])] 17 | type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))] 18 | 19 | miniCat :: Text -> Handler IO MiniCat 20 | miniCat name = pure (returns name :<> returns 32) 21 | 22 | miniDog :: Handler IO MiniDog 23 | miniDog = pure (returns 100) 24 | 25 | catOrDog :: Handler IO CatOrDog 26 | catOrDog = pure $ do 27 | name <- pure "MonadicFelix" -- we can do monadic actions 28 | unionValue @MiniCat (miniCat name) 29 | 30 | catOrDogList :: Handler IO CatOrDogList 31 | catOrDogList = pure $ 32 | returns [ unionValue @MiniCat (miniCat "Felix") 33 | , unionValue @MiniCat (miniCat "Mini") 34 | , unionValue @MiniDog miniDog 35 | ] 36 | 37 | main :: IO () 38 | main = do 39 | response <- interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" 40 | putStrLn $ Aeson.encode $ toValue response 41 | response' <- interpretAnonymousQuery @CatOrDogList catOrDogList "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" 42 | putStrLn $ Aeson.encode $ toValue response' 43 | -------------------------------------------------------------------------------- /graphql-api.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: e921bbdc9931b5b0b16603d36a3252522602c736862259ef71abdecf046541e2 6 | 7 | name: graphql-api 8 | version: 0.3.0 9 | synopsis: GraphQL API 10 | description: Implement [GraphQL](http://graphql.org/) servers in Haskell. 11 | . 12 | Provides a Servant-like type-based API for defining GraphQL schemas and 13 | implementing handlers for those schemas. 14 | . 15 | See [README.md](https://github.com/haskell-graphql/graphql-api#graphql-api) for more details. 16 | category: Web 17 | stability: unstable 18 | homepage: https://github.com/haskell-graphql/graphql-api#readme 19 | bug-reports: https://github.com/haskell-graphql/graphql-api/issues 20 | author: Jonathan M. Lange, Tom Hunger 21 | maintainer: Jonathan M. Lange , Tom Hunger 22 | license: Apache 23 | license-file: LICENSE.Apache-2.0 24 | build-type: Simple 25 | cabal-version: >= 1.10 26 | extra-source-files: 27 | CHANGELOG.rst 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/haskell-graphql/graphql-api 32 | 33 | library 34 | hs-source-dirs: 35 | src 36 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 37 | ghc-options: -Wall -fno-warn-redundant-constraints 38 | build-depends: 39 | QuickCheck 40 | , aeson 41 | , attoparsec 42 | , base >=4.9 && <5 43 | , containers 44 | , exceptions 45 | , ghc-prim 46 | , protolude >=0.2.1 47 | , scientific 48 | , text 49 | , transformers 50 | exposed-modules: 51 | GraphQL 52 | GraphQL.API 53 | GraphQL.Internal.API 54 | GraphQL.Internal.API.Enum 55 | GraphQL.Internal.Arbitrary 56 | GraphQL.Internal.Execution 57 | GraphQL.Internal.Name 58 | GraphQL.Internal.OrderedMap 59 | GraphQL.Internal.Output 60 | GraphQL.Internal.Resolver 61 | GraphQL.Internal.Schema 62 | GraphQL.Internal.Syntax.AST 63 | GraphQL.Internal.Syntax.Encoder 64 | GraphQL.Internal.Syntax.Parser 65 | GraphQL.Internal.Syntax.Tokens 66 | GraphQL.Internal.Validation 67 | GraphQL.Internal.Value 68 | GraphQL.Internal.Value.FromValue 69 | GraphQL.Internal.Value.ToValue 70 | GraphQL.Resolver 71 | GraphQL.Value 72 | other-modules: 73 | Paths_graphql_api 74 | default-language: Haskell2010 75 | 76 | executable input-object-example 77 | main-is: InputObject.hs 78 | hs-source-dirs: 79 | examples 80 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 81 | ghc-options: -Wall -fno-warn-redundant-constraints 82 | build-depends: 83 | aeson 84 | , attoparsec 85 | , base >=4.9 && <5 86 | , exceptions 87 | , graphql-api 88 | , protolude >=0.2.1 89 | , transformers 90 | default-language: Haskell2010 91 | 92 | executable union-example 93 | main-is: UnionExample.hs 94 | hs-source-dirs: 95 | examples 96 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 97 | ghc-options: -Wall -fno-warn-redundant-constraints 98 | build-depends: 99 | aeson 100 | , attoparsec 101 | , base >=4.9 && <5 102 | , exceptions 103 | , graphql-api 104 | , protolude >=0.2.1 105 | , transformers 106 | default-language: Haskell2010 107 | 108 | test-suite graphql-api-doctests 109 | type: exitcode-stdio-1.0 110 | main-is: Main.hs 111 | hs-source-dirs: 112 | tests/doctests 113 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 114 | ghc-options: -Wall -fno-warn-redundant-constraints -threaded 115 | build-depends: 116 | attoparsec 117 | , base >=4.9 && <5 118 | , doctest 119 | , exceptions 120 | , protolude >=0.2.1 121 | , transformers 122 | other-modules: 123 | Paths_graphql_api 124 | default-language: Haskell2010 125 | 126 | test-suite graphql-api-tests 127 | type: exitcode-stdio-1.0 128 | main-is: Main.hs 129 | hs-source-dirs: 130 | tests 131 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 132 | ghc-options: -Wall -fno-warn-redundant-constraints 133 | build-depends: 134 | QuickCheck 135 | , aeson 136 | , attoparsec 137 | , base >=4.9 && <5 138 | , containers 139 | , directory 140 | , exceptions 141 | , graphql-api 142 | , hspec 143 | , protolude >=0.2.1 144 | , raw-strings-qq 145 | , transformers 146 | other-modules: 147 | ASTSpec 148 | EndToEndSpec 149 | EnumTests 150 | ExampleSchema 151 | OrderedMapSpec 152 | ResolverSpec 153 | SchemaSpec 154 | Spec 155 | ValidationSpec 156 | ValueSpec 157 | Paths_graphql_api 158 | default-language: Haskell2010 159 | 160 | benchmark criterion 161 | type: exitcode-stdio-1.0 162 | main-is: Main.hs 163 | hs-source-dirs: 164 | benchmarks 165 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 166 | ghc-options: -Wall -fno-warn-redundant-constraints 167 | build-depends: 168 | attoparsec 169 | , base >=4.9 && <5 170 | , criterion 171 | , exceptions 172 | , graphql-api 173 | , protolude >=0.2.1 174 | , transformers 175 | other-modules: 176 | Validation 177 | Paths_graphql_api 178 | default-language: Haskell2010 179 | -------------------------------------------------------------------------------- /graphql-wai/graphql-wai.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.20.0. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 12d030d800c1c036c89a9464dd8de8b05f9f6dc28e0faae9d2b105b2b120460e 6 | 7 | name: graphql-wai 8 | version: 0.1.0 9 | synopsis: A simple wai adapter 10 | category: Web 11 | homepage: https://github.com/jml/graphql-api#readme 12 | bug-reports: https://github.com/jml/graphql-api/issues 13 | license: Apache 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/jml/graphql-api 20 | 21 | library 22 | hs-source-dirs: 23 | src 24 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 25 | ghc-options: -Wall -fno-warn-redundant-constraints -Werror 26 | build-depends: 27 | aeson 28 | , base >=4.9 && <5 29 | , exceptions 30 | , graphql-api 31 | , http-types 32 | , protolude 33 | , wai 34 | exposed-modules: 35 | GraphQL.Wai 36 | other-modules: 37 | Paths_graphql_wai 38 | default-language: Haskell2010 39 | 40 | test-suite wai-tests 41 | type: exitcode-stdio-1.0 42 | main-is: Tests.hs 43 | hs-source-dirs: 44 | tests 45 | default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications 46 | ghc-options: -Wall -fno-warn-redundant-constraints -Werror 47 | build-depends: 48 | aeson 49 | , base >=4.9 && <5 50 | , exceptions 51 | , graphql-api 52 | , graphql-wai 53 | , http-types 54 | , protolude 55 | , wai 56 | , wai-extra 57 | other-modules: 58 | Paths_graphql_wai 59 | default-language: Haskell2010 60 | -------------------------------------------------------------------------------- /graphql-wai/package.yaml: -------------------------------------------------------------------------------- 1 | name: graphql-wai 2 | version: 0.1.0 3 | synopsis: A simple wai adapter 4 | license: Apache 5 | github: jml/graphql-api 6 | category: Web 7 | 8 | # NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 9 | ghc-options: -Wall -fno-warn-redundant-constraints -Werror 10 | default-extensions: 11 | - NoImplicitPrelude 12 | - OverloadedStrings 13 | - RecordWildCards 14 | - TypeApplications 15 | 16 | dependencies: 17 | - base >= 4.9 && < 5 18 | - protolude 19 | - exceptions 20 | - wai 21 | - http-types 22 | - graphql-api 23 | - aeson 24 | 25 | library: 26 | source-dirs: src 27 | 28 | tests: 29 | wai-tests: 30 | main: Tests.hs 31 | source-dirs: tests 32 | dependencies: 33 | - wai-extra 34 | - graphql-wai -------------------------------------------------------------------------------- /graphql-wai/src/GraphQL/Wai.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | -- | Basic WAI handlers for graphql-api 7 | module GraphQL.Wai 8 | ( toApplication 9 | ) where 10 | 11 | import Protolude 12 | 13 | import qualified Data.Aeson as Aeson 14 | import Network.Wai (Application, queryString, responseLBS) 15 | import Network.HTTP.Types.Header (hContentType) 16 | import Network.HTTP.Types.Status (status200, status400) 17 | 18 | import GraphQL (interpretAnonymousQuery) 19 | import GraphQL.API (HasObjectDefinition, Object) 20 | import GraphQL.Resolver (HasResolver, Handler, OperationResolverConstraint) 21 | import GraphQL.Value (toValue) 22 | 23 | 24 | -- | Adapt a GraphQL handler to a WAI application. This is really just 25 | -- to illustrate the mechanism, and not production ready at this point 26 | -- in time. 27 | -- 28 | -- If you have a 'Cat' type and a corresponding 'catHandler' then you 29 | -- can use "toApplication @Cat catHandler". 30 | toApplication 31 | :: forall r typeName interfaces fields. 32 | ( HasResolver IO r 33 | , r ~ Object typeName interfaces fields 34 | , OperationResolverConstraint IO fields typeName interfaces 35 | , HasObjectDefinition r 36 | ) 37 | => Handler IO r -> Application 38 | toApplication handler = app 39 | where 40 | app req respond = 41 | case queryString req of 42 | [("query", Just query)] -> do 43 | r <- interpretAnonymousQuery @r handler (toS query) 44 | let json = Aeson.encode (toValue r) 45 | respond $ responseLBS status200 [(hContentType, "application/json")] json 46 | _ -> respond $ responseLBS status400 [] "Must provide excatly one query GET argument." 47 | -------------------------------------------------------------------------------- /graphql-wai/tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module Main where 3 | 4 | import Protolude 5 | 6 | import Network.Wai.Test 7 | import GraphQL.API 8 | import GraphQL.Wai 9 | import GraphQL.Resolver 10 | 11 | type Cat = Object "Cat" '[] '[Field "name" Text] 12 | 13 | catHandler :: Handler IO Cat 14 | catHandler = pure (returns "Felix") 15 | 16 | test1 :: Session () 17 | test1 = do 18 | r <- request $ setPath defaultRequest "/?query={ name }" 19 | assertStatus 200 r 20 | assertBody "{\"data\":{\"name\":\"Felix\"}}" r 21 | 22 | main :: IO () 23 | main = do 24 | void $ runSession test1 (toApplication @Cat catHandler) 25 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: graphql-api 2 | version: 0.3.0 3 | synopsis: GraphQL API 4 | description: | 5 | Implement [GraphQL](http://graphql.org/) servers in Haskell. 6 | 7 | Provides a Servant-like type-based API for defining GraphQL schemas and 8 | implementing handlers for those schemas. 9 | 10 | See [README.md](https://github.com/haskell-graphql/graphql-api#graphql-api) for more details. 11 | author: Jonathan M. Lange, Tom Hunger 12 | maintainer: Jonathan M. Lange , Tom Hunger 13 | license: Apache 14 | license-file: LICENSE.Apache-2.0 15 | github: haskell-graphql/graphql-api 16 | category: Web 17 | stability: unstable 18 | extra-source-files: 19 | - CHANGELOG.rst 20 | 21 | # NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 22 | ghc-options: -Wall -fno-warn-redundant-constraints 23 | default-extensions: 24 | - NoImplicitPrelude 25 | - OverloadedStrings 26 | - RecordWildCards 27 | - TypeApplications 28 | 29 | dependencies: 30 | - base >= 4.9 && < 5 31 | - protolude >= 0.2.1 32 | - exceptions 33 | - transformers 34 | - attoparsec 35 | 36 | library: 37 | source-dirs: src 38 | dependencies: 39 | - aeson 40 | - containers 41 | - ghc-prim 42 | - scientific 43 | - QuickCheck 44 | - text 45 | 46 | executables: 47 | input-object-example: 48 | main: InputObject.hs 49 | source-dirs: examples 50 | other-modules: [] 51 | dependencies: 52 | - aeson 53 | - graphql-api 54 | 55 | union-example: 56 | main: UnionExample.hs 57 | source-dirs: examples 58 | other-modules: [] 59 | dependencies: 60 | - aeson 61 | - graphql-api 62 | 63 | tests: 64 | graphql-api-tests: 65 | main: Main.hs 66 | source-dirs: tests 67 | dependencies: 68 | - aeson 69 | - containers 70 | - graphql-api 71 | - hspec 72 | - QuickCheck 73 | - raw-strings-qq 74 | - directory 75 | 76 | graphql-api-doctests: 77 | main: Main.hs 78 | ghc-options: -threaded 79 | source-dirs: tests/doctests 80 | dependencies: 81 | - doctest 82 | 83 | benchmarks: 84 | criterion: 85 | main: Main.hs 86 | source-dirs: benchmarks 87 | dependencies: 88 | - criterion 89 | - graphql-api 90 | -------------------------------------------------------------------------------- /scripts/build-image: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | image_tag="${1}" 4 | 5 | 6 | image_id=$(stack --docker image container --build | tail -n-1 | awk '{{ print $3 }}') 7 | image_name=$(docker images --format '{{ .Repository }}\t{{ .ID }}' | grep "${image_id}" | head -n1 | cut -f1) 8 | 9 | 10 | docker tag "${image_id}" "${image_name}:${image_tag}" 11 | echo "${image_name}:${image_tag}" 12 | -------------------------------------------------------------------------------- /scripts/hpc-ratchet: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | """Ensure our test coverage only increases. 3 | 4 | Easier than figuring out how to get hpc-coveralls to work with Stack. 5 | 6 | If this fails, and the coverage went down: add some tests. 7 | If this fails, and the coverage went up: edit ``DESIRED_COVERAGE`` to match the new value. 8 | If this succeeds, great. 9 | 10 | If you want to get details of what's covered, run:: 11 | 12 | $ stack test --coverage 13 | 14 | And look at the generated HTML. 15 | """ 16 | 17 | from __future__ import division 18 | from pprint import pprint 19 | import re 20 | import subprocess 21 | import sys 22 | 23 | 24 | EXPRESSIONS = 'expressions' 25 | BOOLEANS = 'booleans' 26 | ALTERNATIVES = 'alternatives' 27 | LOCAL_DECLS = 'local_decls' 28 | TOP_LEVEL_DECLS = 'top_level_decls' 29 | 30 | 31 | """The lack of coverage we are willing to tolerate. 32 | 33 | In a just world, this would be a separate config file, or command-line arguments. 34 | 35 | Each item represents the number of "things" we are OK with not being covered. 36 | """ 37 | COVERAGE_TOLERANCE = { 38 | ALTERNATIVES: 151, 39 | BOOLEANS: 8, 40 | EXPRESSIONS: 1351, 41 | LOCAL_DECLS: 10, 42 | TOP_LEVEL_DECLS: 670, 43 | } 44 | 45 | 46 | def get_report_summary(): 47 | """Run ``stack hpc report --all`` and return the output. 48 | 49 | Assumes that ``stack test --coverage`` has already been run. 50 | """ 51 | process = subprocess.Popen(["stack", "hpc", "report", "--all"], stderr=subprocess.PIPE) 52 | stdout, stderr = process.communicate() 53 | return stderr 54 | 55 | 56 | """Parse a line from the summary. 57 | 58 | Takes a line like: 59 | NN% thingy wotsit used (YYYY/ZZZZ) 60 | 61 | And turns it into: 62 | ("thingy wotsit used", "YYYY", "ZZZZ") 63 | """ 64 | _summary_line_re = re.compile(r'^\d\d% ([a-z -]+) \((\d+)/(\d+)\)$') 65 | 66 | 67 | """Map from the human-readable descriptions to keys in the summary dict.""" 68 | _summary_line_entries = { 69 | 'expressions used': EXPRESSIONS, 70 | 'boolean coverage': BOOLEANS, 71 | 'alternatives used': ALTERNATIVES, 72 | 'local declarations used': LOCAL_DECLS, 73 | 'top-level declarations used': TOP_LEVEL_DECLS, 74 | } 75 | 76 | def parse_summary_line(summary_line): 77 | """Parse a line in the summary that indicates coverage we want to ratchet. 78 | 79 | Turns:: 80 | 81 | NN% thingy wotsit used (YYYY/ZZZZ) 82 | 83 | Into:: 84 | 85 | ('thingy', YYYY, ZZZZ) 86 | 87 | Returns ``None`` if the line doesn't match the pattern. 88 | """ 89 | match = _summary_line_re.match(summary_line.strip()) 90 | if match is None: 91 | return 92 | description, covered, total = match.groups() 93 | try: 94 | key = _summary_line_entries[description] # XXX: Explodes if output changes. 95 | except KeyError: 96 | return 97 | return key, int(covered), int(total) 98 | 99 | 100 | def parse_report_summary(summary): 101 | """Parse the output of ``stack hpc report --all``. 102 | 103 | Turns this:: 104 | 105 | Getting project config file from STACK_YAML environment 106 | Generating combined report 107 | 57% expressions used (2172/3801) 108 | 47% boolean coverage (9/19) 109 | 38% guards (5/13), 4 always True, 4 unevaluated 110 | 75% 'if' conditions (3/4), 1 unevaluated 111 | 50% qualifiers (1/2), 1 always True 112 | 45% alternatives used (156/344) 113 | 81% local declarations used (70/86) 114 | 33% top-level declarations used (348/1052) 115 | The combined report is available at /path/hpc_index.html 116 | 117 | Into this:: 118 | 119 | {'expressions': (2172, 3801), 120 | 'booleans': (9, 19), 121 | 'alternatives': (156, 344), 122 | 'local_decls': (70, 86), 123 | 'top_level_decls': (348, 1052), 124 | } 125 | """ 126 | report = {} 127 | for line in summary.splitlines(): 128 | parsed = parse_summary_line(line) 129 | if not parsed: 130 | continue 131 | key, covered, total = parsed 132 | report[key] = (covered, total) 133 | return report 134 | 135 | 136 | def compare_values((covered, total), tolerance): 137 | """Compare measured coverage values with our tolerated lack of coverage. 138 | 139 | Return -1 if coverage has got worse, 0 if it is the same, 1 if it is better. 140 | """ 141 | missing = total - covered 142 | return cmp(tolerance, missing) 143 | 144 | 145 | def compare_coverage(report, desired): 146 | comparison = {} 147 | for key, actual in report.items(): 148 | tolerance = desired.get(key, 0) 149 | if actual: 150 | comparison[key] = compare_values(actual, tolerance) 151 | else: 152 | comparison[key] = None 153 | return comparison 154 | 155 | 156 | def format_result(result): 157 | if result < 0: 158 | return 'WORSE' 159 | elif result == 0: 160 | return 'OK' 161 | else: 162 | return 'BETTER' 163 | 164 | 165 | def format_entry(key, result, desired, actual): 166 | covered, total = actual 167 | formatted_result = format_result(result) 168 | # TODO: Align results 169 | if result: 170 | return '%s: %s (%d missing => %d missing)' % ( 171 | key, formatted_result, desired, total - covered, 172 | ) 173 | else: 174 | return '%s: %s' % (key, formatted_result) 175 | 176 | 177 | def main(): 178 | report = parse_report_summary(get_report_summary()) 179 | comparison = compare_coverage(report, COVERAGE_TOLERANCE) 180 | all_same = True 181 | for key, value in sorted(comparison.items()): 182 | if value != 0: 183 | all_same = False 184 | print format_entry(key, value, COVERAGE_TOLERANCE.get(key, 0), report[key]) 185 | sys.exit(0 if all_same else 2) 186 | 187 | 188 | if __name__ == '__main__': 189 | main() 190 | -------------------------------------------------------------------------------- /scripts/image-tag: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -o errexit 4 | set -o nounset 5 | set -o pipefail 6 | 7 | BRANCH_PREFIX=$(git rev-parse --abbrev-ref HEAD 2>/dev/null || echo "") 8 | if [ -z "${BRANCH_PREFIX}" ]; then 9 | echo "unversioned" 10 | else 11 | WORKING_SUFFIX=$(if ! git diff --exit-code --quiet HEAD >&2; \ 12 | then echo "-WIP"; \ 13 | else echo ""; \ 14 | fi) 15 | echo "${BRANCH_PREFIX//\//-}-$(git rev-parse --short HEAD)$WORKING_SUFFIX" 16 | fi 17 | -------------------------------------------------------------------------------- /scripts/lint: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | hlint -XTypeApplications src/ tests/ 4 | -------------------------------------------------------------------------------- /src/GraphQL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | -- | Interface for GraphQL API. 8 | -- 9 | -- __Note__: This module is highly subject to change. We're still figuring 10 | -- where to draw the lines and what to expose. 11 | module GraphQL 12 | ( 13 | -- * Running queries 14 | interpretQuery 15 | , interpretAnonymousQuery 16 | , Response(..) 17 | -- * Preparing queries then running them 18 | , makeSchema 19 | , compileQuery 20 | , executeQuery 21 | , QueryError 22 | , Schema 23 | , VariableValues 24 | , Value 25 | ) where 26 | 27 | import Protolude 28 | 29 | import Data.Attoparsec.Text (parseOnly, endOfInput) 30 | import Data.List.NonEmpty (NonEmpty(..)) 31 | import qualified Data.List.NonEmpty as NonEmpty 32 | import GraphQL.API (HasObjectDefinition(..), Object, SchemaError(..)) 33 | import GraphQL.Internal.Execution 34 | ( VariableValues 35 | , ExecutionError 36 | , substituteVariables 37 | ) 38 | import qualified GraphQL.Internal.Execution as Execution 39 | import qualified GraphQL.Internal.Syntax.AST as AST 40 | import qualified GraphQL.Internal.Syntax.Parser as Parser 41 | import GraphQL.Internal.Validation 42 | ( QueryDocument 43 | , SelectionSetByType 44 | , ValidationErrors 45 | , validate 46 | , getSelectionSet 47 | , VariableValue 48 | ) 49 | import GraphQL.Internal.Output 50 | ( GraphQLError(..) 51 | , Response(..) 52 | , singleError 53 | ) 54 | import GraphQL.Internal.Schema (Schema) 55 | import qualified GraphQL.Internal.Schema as Schema 56 | import GraphQL.Resolver 57 | ( HasResolver(..) 58 | , OperationResolverConstraint 59 | , Result(..) 60 | , resolveOperation 61 | ) 62 | import GraphQL.Value (Name, Value) 63 | 64 | -- | Errors that can happen while processing a query document. 65 | data QueryError 66 | -- | Failed to parse. 67 | = ParseError Text 68 | -- | Parsed, but failed validation. 69 | -- 70 | -- See for more 71 | -- details. 72 | | ValidationError ValidationErrors 73 | -- | Validated, but failed during execution. 74 | | ExecutionError ExecutionError 75 | -- | Error in the schema. 76 | | SchemaError SchemaError 77 | -- | Got a value that wasn't an object. 78 | | NonObjectResult Value 79 | deriving (Eq, Show) 80 | 81 | instance GraphQLError QueryError where 82 | formatError (ParseError e) = 83 | "Couldn't parse query document: " <> e 84 | formatError (ValidationError es) = 85 | "Validation errors:\n" <> mconcat [" " <> formatError e <> "\n" | e <- NonEmpty.toList es] 86 | formatError (ExecutionError e) = 87 | "Execution error: " <> show e 88 | formatError (SchemaError e) = 89 | "Schema error: " <> formatError e 90 | formatError (NonObjectResult v) = 91 | "Query returned a value that is not an object: " <> show v 92 | 93 | -- | Execute a GraphQL query. 94 | executeQuery 95 | :: forall api m fields typeName interfaces. 96 | ( Object typeName interfaces fields ~ api 97 | , OperationResolverConstraint m fields typeName interfaces 98 | ) 99 | => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. 100 | -> QueryDocument VariableValue -- ^ A validated query document. Build one with 'compileQuery'. 101 | -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something". 102 | -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. 103 | -> m Response -- ^ The outcome of running the query. 104 | executeQuery handler document name variables = 105 | case getOperation document name variables of 106 | Left e -> pure (ExecutionFailure (singleError e)) 107 | Right operation -> 108 | toResult 109 | <$> resolveOperation @m @fields @typeName @interfaces handler operation 110 | where 111 | toResult (Result errors object) = 112 | case NonEmpty.nonEmpty errors of 113 | Nothing -> Success object 114 | Just errs -> PartialSuccess object (map toError errs) 115 | 116 | -- | Create a GraphQL schema. 117 | makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema 118 | makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api) 119 | 120 | -- | Interpet a GraphQL query. 121 | -- 122 | -- Compiles then executes a GraphQL query. 123 | interpretQuery 124 | :: forall api m fields typeName interfaces. 125 | ( Object typeName interfaces fields ~ api 126 | , OperationResolverConstraint m fields typeName interfaces 127 | ) 128 | => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. 129 | -> Text -- ^ The text of a query document. Will be parsed and then executed. 130 | -> 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"@. 131 | -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. 132 | -> m Response -- ^ The outcome of running the query. 133 | interpretQuery handler query name variables = 134 | case makeSchema @api >>= flip compileQuery query of 135 | Left err -> pure (PreExecutionFailure (toError err :| [])) 136 | Right document -> executeQuery @api @m handler document name variables 137 | 138 | -- | Interpret an anonymous GraphQL query. 139 | -- 140 | -- Anonymous queries have no name and take no variables. 141 | interpretAnonymousQuery 142 | :: forall api m fields typeName interfaces. 143 | ( Object typeName interfaces fields ~ api 144 | , OperationResolverConstraint m fields typeName interfaces 145 | ) 146 | => Handler m api -- ^ Handler for the anonymous query. 147 | -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation. 148 | -> m Response -- ^ The result of running the query. 149 | interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty 150 | 151 | -- | Turn some text into a valid query document. 152 | compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue) 153 | compileQuery schema query = do 154 | parsed <- first ParseError (parseQuery query) 155 | first ValidationError (validate schema parsed) 156 | 157 | -- | Parse a query document. 158 | parseQuery :: Text -> Either Text AST.QueryDocument 159 | parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query) 160 | 161 | -- | Get an operation from a query document ready to be processed. 162 | getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value) 163 | getOperation document name vars = first ExecutionError $ do 164 | op <- Execution.getOperation document name 165 | resolved <- substituteVariables op vars 166 | pure (getSelectionSet resolved) 167 | -------------------------------------------------------------------------------- /src/GraphQL/API.hs: -------------------------------------------------------------------------------- 1 | -- | Description: Define a GraphQL schema with Haskell types 2 | -- 3 | -- Use this to define your GraphQL schema with Haskell types. 4 | module GraphQL.API 5 | ( Object 6 | , Field 7 | , Argument 8 | , Union 9 | , List 10 | , Enum 11 | , GraphQLEnum(..) 12 | , Interface 13 | , (:>)(..) 14 | , Defaultable(..) 15 | , HasObjectDefinition(..) 16 | , HasAnnotatedInputType(..) 17 | , SchemaError(..) 18 | ) where 19 | 20 | import GraphQL.Internal.API 21 | ( Object 22 | , Field 23 | , Argument 24 | , Union 25 | , List 26 | , Enum 27 | , GraphQLEnum(..) 28 | , Interface 29 | , (:>)(..) 30 | , Defaultable(..) 31 | , HasObjectDefinition(..) 32 | , HasAnnotatedInputType(..) 33 | , SchemaError(..) 34 | ) 35 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/API/Enum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# OPTIONS_HADDOCK not-home #-} 11 | 12 | -- | Description: Define GraphQL Enums with Haskell types 13 | module GraphQL.Internal.API.Enum 14 | ( GraphQLEnum(..) 15 | ) where 16 | 17 | import Protolude hiding (Enum, TypeError) 18 | 19 | import GHC.Generics (D, (:+:)(..)) 20 | import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) 21 | import GHC.Types (Type) 22 | 23 | import GraphQL.Internal.Name (Name, nameFromSymbol, NameError) 24 | import GraphQL.Internal.Output (GraphQLError(..)) 25 | 26 | invalidEnumName :: forall t. NameError -> Either Text t 27 | invalidEnumName x = Left ("In Enum: " <> formatError x) 28 | 29 | -- TODO: Enums have a slightly more restricted set of names than 'Name' 30 | -- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser 31 | -- /probably/ guarantees this, so it should export this guarantee by providing 32 | -- an 'Enum' type. 33 | 34 | class GenericEnumValues (f :: Type -> Type) where 35 | genericEnumValues :: [Either NameError Name] 36 | -- XXX: Why is this 'Text' and not 'NameError'? 37 | genericEnumFromValue :: Name -> Either Text (f p) 38 | genericEnumToValue :: f p -> Name 39 | 40 | instance forall conName m p f nt. 41 | ( KnownSymbol conName 42 | , KnownSymbol m 43 | , KnownSymbol p 44 | , GenericEnumValues f 45 | ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where 46 | genericEnumValues = genericEnumValues @f 47 | genericEnumFromValue name = M1 <$> genericEnumFromValue name 48 | genericEnumToValue (M1 gv) = genericEnumToValue gv 49 | 50 | instance forall left right. 51 | ( GenericEnumValues left 52 | , GenericEnumValues right 53 | ) => GenericEnumValues (left :+: right) where 54 | genericEnumValues = genericEnumValues @left <> genericEnumValues @right 55 | genericEnumFromValue vname = 56 | let left = genericEnumFromValue @left vname 57 | right = genericEnumFromValue @right vname 58 | in case (left, right) of 59 | (x@(Right _), Left _) -> L1 <$> x 60 | (Left _, x@(Right _)) -> R1 <$> x 61 | (err@(Left _), Left _) -> L1 <$> err 62 | _ -> panic "Can't have two successful branches in Haskell" 63 | 64 | genericEnumToValue (L1 gv) = genericEnumToValue gv 65 | genericEnumToValue (R1 gv) = genericEnumToValue gv 66 | 67 | instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where 68 | genericEnumValues = let name = nameFromSymbol @conName in [name] 69 | genericEnumFromValue vname = 70 | case nameFromSymbol @conName of 71 | Right name -> if name == vname 72 | then Right (M1 U1) 73 | else Left ("Not a valid choice for enum: " <> show vname) 74 | -- XXX: This is impossible to catch during validation, because we cannot 75 | -- validate type-level symbols, we can only validate values. We could 76 | -- show that the schema is invalid at the type-level and still decide to 77 | -- call this anyway. The error should rather say that the schema is 78 | -- invalid. 79 | -- 80 | -- Further, we don't actually have any schema-level validation, so 81 | -- "should have been caught during validation" is misleading. 82 | Left x -> invalidEnumName x 83 | genericEnumToValue (M1 _) = 84 | let Right name = nameFromSymbol @conName 85 | in name 86 | 87 | -- TODO(tom): better type errors using `n`. Also type errors for other 88 | -- invalid constructors. 89 | instance forall conName p b sa sb. 90 | ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) 91 | , KnownSymbol conName 92 | ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where 93 | genericEnumValues = nonUnaryConstructorError 94 | genericEnumFromValue = nonUnaryConstructorError 95 | genericEnumToValue = nonUnaryConstructorError 96 | 97 | instance forall conName p b sa sb f. 98 | ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) 99 | , KnownSymbol conName 100 | ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where 101 | genericEnumValues = nonUnaryConstructorError 102 | genericEnumFromValue = nonUnaryConstructorError 103 | genericEnumToValue = nonUnaryConstructorError 104 | 105 | nonUnaryConstructorError :: a 106 | nonUnaryConstructorError = panic "Tried to construct enum with non-unary constructor. Should get a compile-time error instead of this." 107 | 108 | -- | For each enum type we need 1) a list of all possible values 2) a 109 | -- way to serialise and 3) deserialise. 110 | -- 111 | -- TODO: Update this comment to explain what a GraphQLEnum is, why you might 112 | -- want an instance, and any laws that apply to method relations. 113 | class GraphQLEnum a where 114 | -- TODO: Document each of these methods. 115 | enumValues :: [Either NameError Name] 116 | default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name] 117 | enumValues = genericEnumValues @(Rep a) 118 | 119 | enumFromValue :: Name -> Either Text a 120 | default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a 121 | enumFromValue v = to <$> genericEnumFromValue v 122 | 123 | enumToValue :: a -> Name 124 | default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name 125 | enumToValue = genericEnumToValue . from 126 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | 4 | -- | Description: QuickCheck instances to help with testing 5 | module GraphQL.Internal.Arbitrary 6 | ( arbitraryText 7 | , arbitraryNonEmpty 8 | ) where 9 | 10 | import Protolude 11 | 12 | import qualified Data.List.NonEmpty as NonEmpty 13 | import Data.List.NonEmpty (NonEmpty) 14 | import qualified Data.String 15 | import Test.QuickCheck (Gen, Arbitrary(..), arbitrary, listOf1) 16 | 17 | -- | Generate arbitrary 'Text'. 18 | arbitraryText :: Gen Text 19 | arbitraryText = toS <$> arbitrary @Data.String.String 20 | 21 | -- | Generate an arbitrary 'NonEmpty' list. 22 | arbitraryNonEmpty :: forall a. Arbitrary a => Gen (NonEmpty a) 23 | arbitraryNonEmpty = 24 | -- NonEmpty.fromList panics, but that's OK, because listOf1 is guaranteed to 25 | -- return a non-empty list, and because a panic in a test is highly 26 | -- informative and indicative of a bug. 27 | NonEmpty.fromList <$> listOf1 arbitrary 28 | 29 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Execution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | -- | Description: Implement the \"Execution\" part of the GraphQL spec. 6 | -- 7 | -- Actually, most of the execution work takes place in 'GraphQL.Resolver', but 8 | -- there's still a fair bit required to glue together the results of 9 | -- 'GraphQL.Internal.Validation' and the processing in 'GraphQL.Resolver'. 10 | -- This module provides that glue. 11 | module GraphQL.Internal.Execution 12 | ( VariableValues 13 | , ExecutionError(..) 14 | , formatError 15 | , getOperation 16 | , substituteVariables 17 | ) where 18 | 19 | import Protolude 20 | 21 | import qualified Data.Map as Map 22 | import GraphQL.Value 23 | ( Name 24 | , Value 25 | , pattern ValueNull 26 | , Value'(..) 27 | , List'(..) 28 | , Object'(..) 29 | ) 30 | import GraphQL.Internal.Output (GraphQLError(..)) 31 | import GraphQL.Internal.Schema 32 | ( AnnotatedType (TypeNonNull) 33 | ) 34 | import GraphQL.Internal.Validation 35 | ( Operation 36 | , QueryDocument(..) 37 | , VariableDefinition(..) 38 | , VariableValue 39 | , Variable 40 | ) 41 | 42 | -- | Get an operation from a GraphQL document 43 | -- 44 | -- 45 | -- 46 | -- GetOperation(document, operationName): 47 | -- 48 | -- * If {operationName} is {null}: 49 | -- * If {document} contains exactly one operation. 50 | -- * Return the Operation contained in the {document}. 51 | -- * Otherwise produce a query error requiring {operationName}. 52 | -- * Otherwise: 53 | -- * Let {operation} be the Operation named {operationName} in {document}. 54 | -- * If {operation} was not found, produce a query error. 55 | -- * Return {operation}. 56 | getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value) 57 | getOperation (LoneAnonymousOperation op) Nothing = pure op 58 | getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup (pure name) ops) 59 | getOperation (MultipleOperations ops) Nothing = 60 | case toList ops of 61 | [op] -> pure op 62 | _ -> throwError NoAnonymousOperation 63 | getOperation _ (Just name) = throwError (NoSuchOperation name) 64 | 65 | 66 | -- | Substitute variables in a GraphQL document. 67 | -- 68 | -- Once this is done, there will be no variables in the document whatsoever. 69 | substituteVariables :: Operation VariableValue -> VariableValues -> Either ExecutionError (Operation Value) 70 | substituteVariables op vars = traverse (replaceVariable vars) op 71 | 72 | replaceVariable :: VariableValues -> VariableValue -> Either ExecutionError Value 73 | replaceVariable vars value = 74 | case value of 75 | ValueScalar' (Left defn) -> getValue defn 76 | ValueScalar' (Right v) -> pure (ValueScalar' v) 77 | ValueList' (List' xs) -> ValueList' . List' <$> traverse (replaceVariable vars) xs 78 | ValueObject' (Object' xs) -> ValueObject' . Object' <$> traverse (replaceVariable vars) xs 79 | where 80 | 81 | getValue :: VariableDefinition -> Either ExecutionError Value 82 | getValue (VariableDefinition variableName variableType defaultValue) = 83 | note (MissingValue variableName) $ 84 | Map.lookup variableName vars <|> defaultValue <|> allowNull variableType 85 | 86 | allowNull (TypeNonNull _) = empty 87 | allowNull _ = pure ValueNull 88 | 89 | -- | An error that occurs while executing a query. Technically, 90 | -- 'ResolverError' also falls into the same category, but is separate to help 91 | -- our code be a bit better organized. 92 | data ExecutionError 93 | = MissingValue Variable 94 | | NoSuchOperation Name 95 | | NoAnonymousOperation 96 | deriving (Eq, Show) 97 | 98 | instance GraphQLError ExecutionError where 99 | formatError (MissingValue name) = "Missing value for " <> show name <> " and must be non-null." 100 | formatError (NoSuchOperation name) = "Requested operation " <> show name <> " but couldn't find it." 101 | formatError NoAnonymousOperation = "No name supplied for opertaion, but no anonymous operation." 102 | 103 | -- | A map of variables to their values. 104 | -- 105 | -- In GraphQL the variable values are not part of the query itself, they are 106 | -- instead passed in through a separate channel. Create a 'VariableValues' 107 | -- from this other channel and pass it to 'substituteVariables'. 108 | -- 109 | -- GraphQL allows the values of variables to be specified, but doesn't provide 110 | -- a way for doing so in the language. 111 | type VariableValues = Map Variable Value 112 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# OPTIONS_HADDOCK not-home #-} 7 | 8 | -- | Description: Representation of GraphQL names. 9 | module GraphQL.Internal.Name 10 | ( Name(unName, Name) 11 | , NameError(..) 12 | , makeName 13 | , nameFromSymbol 14 | , nameParser 15 | -- * Named things 16 | , HasName(..) 17 | -- * Unsafe functions 18 | , unsafeMakeName 19 | ) where 20 | 21 | import Protolude 22 | 23 | import qualified Data.Aeson as Aeson 24 | import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) 25 | import Data.Char (isDigit) 26 | import Data.Text as T (Text) 27 | import qualified Data.Attoparsec.Text as A 28 | import Test.QuickCheck (Arbitrary(..), elements, listOf) 29 | import Data.String (IsString(..)) 30 | 31 | import GraphQL.Internal.Syntax.Tokens (tok) 32 | 33 | -- * Name 34 | 35 | -- | A name in GraphQL. 36 | -- 37 | -- https://facebook.github.io/graphql/#sec-Names 38 | newtype Name = Name { unName :: T.Text } deriving (Eq, Ord, Show) 39 | 40 | 41 | -- | Create a 'Name', panicking if the given text is invalid. 42 | -- 43 | -- Prefer 'makeName' to this in all cases. 44 | -- 45 | -- >>> unsafeMakeName "foo" 46 | -- Name {unName = "foo"} 47 | unsafeMakeName :: HasCallStack => Text -> Name 48 | unsafeMakeName name = 49 | case makeName name of 50 | Left e -> panic (show e) 51 | Right n -> n 52 | 53 | -- | Create a 'Name'. 54 | -- 55 | -- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does 56 | -- not match, return NameError. 57 | -- 58 | -- >>> makeName "foo" 59 | -- Right (Name {unName = "foo"}) 60 | -- >>> makeName "9-bar" 61 | -- Left (NameError "9-bar") 62 | makeName :: Text -> Either NameError Name 63 | makeName name = first (const (NameError name)) (A.parseOnly nameParser name) 64 | 65 | -- | Parser for 'Name'. 66 | nameParser :: A.Parser Name 67 | nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z 68 | <*> A.takeWhile ((||) <$> isDigit <*> isA_z)) 69 | where 70 | -- `isAlpha` handles many more Unicode Chars 71 | isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z'] 72 | 73 | -- | An invalid name. 74 | newtype NameError = NameError Text deriving (Eq, Show) 75 | 76 | -- | Convert a type-level 'Symbol' into a GraphQL 'Name'. 77 | nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name 78 | nameFromSymbol = makeName (toS (symbolVal @n Proxy)) 79 | 80 | -- | Types that implement this have values with a single canonical name in a 81 | -- GraphQL schema. 82 | -- 83 | -- e.g. a field @foo(bar: Int32)@ would have the name @\"foo\"@. 84 | -- 85 | -- If a thing *might* have a name, or has a name that might not be valid, 86 | -- don't use this. 87 | -- 88 | -- If a thing is aliased, then return the *original* name. 89 | class HasName a where 90 | -- | Get the name of the object. 91 | getName :: a -> Name 92 | 93 | instance IsString Name where 94 | fromString = unsafeMakeName . toS 95 | 96 | instance Aeson.ToJSON Name where 97 | toJSON = Aeson.toJSON . unName 98 | 99 | instance Arbitrary Name where 100 | arbitrary = do 101 | initial <- elements alpha 102 | rest <- listOf (elements (alpha <> numeric)) 103 | pure (Name (toS (initial:rest))) 104 | where 105 | alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_'] 106 | numeric = ['0'..'9'] 107 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/OrderedMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | 4 | -- | Description: Data structure for mapping keys to values while preserving order of appearance 5 | -- 6 | -- There are many cases in GraphQL where we want to have a map from names to 7 | -- values, where values can easily be lookup up by name and name is unique. 8 | -- This would normally be modelled as a 'Map'. However, in many of these 9 | -- cases, the order in which the entries appear matters. 10 | -- 11 | -- That is, 12 | -- 13 | -- @ 14 | -- { 15 | -- 'foo': 1, 16 | -- 'bar': 2 17 | -- } 18 | -- @ 19 | -- 20 | -- Is different to, 21 | -- 22 | -- @ 23 | -- { 24 | -- 'bar': 2, 25 | -- 'foo': 1, 26 | -- } 27 | -- 28 | -- Even though they have exactly the same keys, and the keys have exactly the 29 | -- same values. 30 | -- 31 | -- Goal for this module is to provide data structures that are "complete 32 | -- enough" for implementing the rest of GraphQL. 33 | module GraphQL.Internal.OrderedMap 34 | ( OrderedMap 35 | -- * Construction 36 | , empty 37 | , singleton 38 | , orderedMap 39 | -- * Querying 40 | , lookup 41 | -- * Filtering 42 | , GraphQL.Internal.OrderedMap.catMaybes 43 | -- * Combine 44 | -- ** Union 45 | , unions 46 | , unionWith 47 | , unionsWith 48 | , unionWithM 49 | , unionsWithM 50 | -- * Conversion 51 | , toList 52 | , toMap 53 | , keys 54 | , values 55 | -- * Properties 56 | , genOrderedMap 57 | ) where 58 | 59 | import Protolude hiding (empty, toList) 60 | 61 | import qualified Data.Map as Map 62 | import Test.QuickCheck (Arbitrary(..), Gen, listOf) 63 | 64 | data OrderedMap key value 65 | = OrderedMap 66 | { -- | Get the list of keys from an ordered map, in order of appearance. 67 | -- 68 | -- This list is guaranteed to have no duplicates. 69 | keys :: [key] 70 | -- | Convert an ordered map to a regular map, losing insertion order. 71 | , toMap :: Map key value 72 | } 73 | deriving (Eq, Ord, Show) 74 | 75 | -- | Convert an ordered map to a list of keys and values. The list is 76 | -- guaranteed to be the same order as the order of insertion into the map. 77 | -- 78 | -- /O(n log n)/ 79 | toList :: forall key value. Ord key => OrderedMap key value -> [(key, value)] 80 | toList (OrderedMap keys entries) = Protolude.catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries) 81 | 82 | instance Foldable (OrderedMap key) where 83 | foldr f z (OrderedMap _ entries) = foldr f z entries 84 | 85 | instance Traversable (OrderedMap key) where 86 | traverse f (OrderedMap keys entries) = OrderedMap keys <$> traverse f entries 87 | 88 | instance Functor (OrderedMap key) where 89 | fmap f (OrderedMap keys entries) = OrderedMap keys (map f entries) 90 | 91 | instance (Arbitrary key, Arbitrary value, Ord key) => Arbitrary (OrderedMap key value) where 92 | arbitrary = genOrderedMap arbitrary arbitrary 93 | 94 | -- | Generate an ordered map with the given key & value generators. 95 | genOrderedMap :: forall key value. Ord key => Gen key -> Gen value -> Gen (OrderedMap key value) 96 | genOrderedMap genKey genValue = do 97 | entries <- Map.fromList <$> (zip <$> listOf genKey <*> listOf genValue) 98 | pure (OrderedMap (Map.keys entries) entries) 99 | 100 | -- | The empty OrderedMap. /O(1)/ 101 | empty :: forall key value. OrderedMap key value 102 | empty = OrderedMap [] Map.empty 103 | 104 | -- | Create an ordered map containing a single entry. /O(1)/ 105 | singleton :: forall key value. key -> value -> OrderedMap key value 106 | singleton key value = OrderedMap [key] (Map.singleton key value) 107 | 108 | -- | Find a value in an ordered map. 109 | -- 110 | -- /O(log n)/ 111 | lookup :: forall key value. Ord key => key -> OrderedMap key value -> Maybe value 112 | lookup key (OrderedMap _ entries) = Map.lookup key entries 113 | 114 | -- | Get the values from an ordered map, in order of appearance. /O(n log n)/ 115 | values :: forall key value. Ord key => OrderedMap key value -> [value] 116 | values = map snd . toList 117 | 118 | -- | The union of a list of ordered maps. 119 | -- 120 | -- If any map shares a key with any other map, return 'Nothing'. 121 | -- 122 | -- Otherwise, return a new map containing all of the keys from all of the 123 | -- maps. The keys from the first map will appear first, followed by the 124 | -- second, and so forth. 125 | -- 126 | -- /O(m * n log (m * n))/ where /m/ is the number of maps, and /n/ is the size of 127 | -- the largest map. 128 | unions :: forall key value. Ord key => [OrderedMap key value] -> Maybe (OrderedMap key value) 129 | unions orderedMaps = orderedMap (orderedMaps >>= toList) 130 | 131 | -- | Append the second ordered map to the first, combining any shared elements 132 | -- with the given function. 133 | unionWith :: Ord key 134 | => (value -> value -> value) 135 | -> OrderedMap key value 136 | -> OrderedMap key value 137 | -> OrderedMap key value 138 | unionWith f x y = 139 | OrderedMap 140 | { toMap = Map.unionWith f (toMap x) (toMap y) 141 | , keys = keys x <> [k | k <- keys y, k `Map.notMember` toMap x] 142 | } 143 | 144 | -- | Append together a list of ordered maps, preserving ordering of keys. 145 | -- Combine any shared elements with the given function. 146 | unionsWith :: Ord key 147 | => (value -> value -> value) 148 | -> [OrderedMap key value] 149 | -> OrderedMap key value 150 | unionsWith f = foldl' (unionWith f) empty 151 | 152 | -- | Take two ordered maps, append the second one to the first. If the second 153 | -- contains any keys that also appear in the first, combine the two values 154 | -- with the given function. 155 | unionWithM :: (Monad m, Ord key) 156 | => (value -> value -> m value) 157 | -> OrderedMap key value 158 | -> OrderedMap key value 159 | -> m (OrderedMap key value) 160 | unionWithM f x y = sequenceA (unionWith (liftMM f) (map pure x) (map pure y)) 161 | 162 | -- | Take a list of ordered maps and append them together. Any shared elements 163 | -- are combined using the given function. 164 | unionsWithM :: (Monad m, Ord key) 165 | => (value -> value -> m value) 166 | -> [OrderedMap key value] 167 | -> m (OrderedMap key value) 168 | unionsWithM f xs = sequenceA (unionsWith (liftMM f) (map (map pure) xs)) 169 | 170 | liftMM :: Monad m => (a -> b -> m c) -> m a -> m b -> m c 171 | liftMM f a' b' = do 172 | (a, b) <- (,) <$> a' <*> b' 173 | f a b 174 | 175 | -- | Take an ordered map with 'Maybe' values and return the same map with all 176 | -- the 'Nothing' values removed. 177 | catMaybes :: Ord key => OrderedMap key (Maybe value) -> OrderedMap key value 178 | catMaybes xs = 179 | OrderedMap 180 | { keys = [ k | k <- keys xs, k `Map.member` newMap ] 181 | , toMap = newMap 182 | } 183 | where 184 | newMap = Map.mapMaybe identity (toMap xs) 185 | 186 | -- | Construct an ordered map from a list. 187 | -- 188 | -- /O(n log n)/. 189 | -- 190 | -- If the list contains duplicate keys, then return 'Nothing'. Otherwise, 191 | -- return an 'OrderedMap', preserving the order. 192 | orderedMap :: forall key value. Ord key => [(key, value)] -> Maybe (OrderedMap key value) 193 | orderedMap entries 194 | | ks == ordNub ks = Just (OrderedMap ks (Map.fromList entries)) 195 | | otherwise = Nothing 196 | where 197 | ks = map fst entries 198 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Output.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | 4 | -- | Description: How we encode GraphQL responses 5 | module GraphQL.Internal.Output 6 | ( Response(..) 7 | , Errors 8 | , Error(..) 9 | , GraphQLError(..) 10 | , singleError 11 | ) where 12 | 13 | import Protolude hiding (Location, Map) 14 | 15 | import Data.Aeson (ToJSON(..)) 16 | import Data.List.NonEmpty (NonEmpty(..)) 17 | 18 | import GraphQL.Value 19 | ( Object 20 | , objectFromList 21 | , Value 22 | , pattern ValueObject 23 | , pattern ValueNull 24 | , NameError(..) 25 | , ToValue(..) 26 | ) 27 | import GraphQL.Internal.Name (Name) 28 | 29 | -- | GraphQL response. 30 | -- 31 | -- A GraphQL response must: 32 | -- 33 | -- * be a map 34 | -- * have a "data" key iff the operation executed 35 | -- * have an "errors" key iff the operation encountered errors 36 | -- * not include "data" if operation failed before execution (e.g. syntax errors, 37 | -- validation errors, missing info) 38 | -- * not have keys other than "data", "errors", and "extensions" 39 | -- 40 | -- Other interesting things: 41 | -- 42 | -- * Doesn't have to be JSON, but does have to have maps, strings, lists, 43 | -- and null 44 | -- * Can also support bool, int, enum, and float 45 | -- * Value of "extensions" must be a map 46 | -- 47 | -- "data" must be null if an error was encountered during execution that 48 | -- prevented a valid response. 49 | -- 50 | -- "errors" 51 | -- 52 | -- * must be a non-empty list 53 | -- * each error is a map with "message", optionally "locations" key 54 | -- with list of locations 55 | -- * locations are maps with 1-indexed "line" and "column" keys. 56 | data Response 57 | = Success Object 58 | | PreExecutionFailure Errors 59 | | ExecutionFailure Errors 60 | | PartialSuccess Object Errors 61 | deriving (Eq, Ord, Show) 62 | 63 | -- | Construct an object from a list of names and values. 64 | -- 65 | -- Panic if there are duplicate names. 66 | unsafeMakeObject :: HasCallStack => [(Name, Value)] -> Value 67 | unsafeMakeObject fields = 68 | case objectFromList fields of 69 | Nothing -> panic $ "Object has duplicate keys: " <> show fields 70 | Just object -> ValueObject object 71 | 72 | instance ToValue Response where 73 | toValue (Success x) = unsafeMakeObject [("data", toValue x)] 74 | toValue (PreExecutionFailure e) = unsafeMakeObject [("errors", toValue e)] 75 | toValue (ExecutionFailure e) = unsafeMakeObject [("data", ValueNull) 76 | ,("errors", toValue e)] 77 | toValue (PartialSuccess x e) = unsafeMakeObject [("data", toValue x) 78 | ,("errors", toValue e) 79 | ] 80 | 81 | instance ToJSON Response where 82 | toJSON = toJSON . toValue 83 | 84 | type Errors = NonEmpty Error 85 | 86 | data Error = Error Text [Location] deriving (Eq, Ord, Show) 87 | 88 | instance ToValue Error where 89 | toValue (Error message []) = unsafeMakeObject [("message", toValue message)] 90 | toValue (Error message locations) = unsafeMakeObject [("message", toValue message) 91 | ,("locations", toValue locations) 92 | ] 93 | 94 | -- | Make a list of errors containing a single error. 95 | singleError :: GraphQLError e => e -> Errors 96 | singleError e = toError e :| [] 97 | 98 | data Location = Location Line Column deriving (Eq, Ord, Show) 99 | type Line = Int32 -- XXX: 1-indexed natural number 100 | type Column = Int32 -- XXX: 1-indexed natural number 101 | 102 | instance ToValue Location where 103 | toValue (Location line column) = unsafeMakeObject [("line" , toValue line) 104 | ,("column", toValue column) 105 | ] 106 | 107 | -- | An error that arises while processing a GraphQL query. 108 | class GraphQLError e where 109 | -- | Represent an error as human-readable text, primarily intended for 110 | -- developers of GraphQL clients, and secondarily for developers of GraphQL 111 | -- servers. 112 | formatError :: e -> Text 113 | 114 | -- | Represent an error as human-readable text, together with reference to a 115 | -- series of locations within a GraphQL query document. Default 116 | -- implementation calls 'formatError' and provides no locations. 117 | toError :: e -> Error 118 | toError e = Error (formatError e) [] 119 | 120 | -- Defined here to avoid circular dependency. 121 | instance GraphQLError NameError where 122 | formatError (NameError name) = "Not a valid GraphQL name: " <> show name 123 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Syntax/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# OPTIONS_HADDOCK not-home #-} 6 | 7 | -- | Description: The GraphQL AST 8 | module GraphQL.Internal.Syntax.AST 9 | ( QueryDocument(..) 10 | , SchemaDocument(..) 11 | , Definition(..) 12 | , OperationDefinition(..) 13 | , Node(..) 14 | , VariableDefinition(..) 15 | , Variable(..) 16 | , SelectionSet 17 | , Selection(..) 18 | , Field(..) 19 | , Alias 20 | , Argument(..) 21 | , FragmentSpread(..) 22 | , InlineFragment(..) 23 | , FragmentDefinition(..) 24 | , TypeCondition 25 | , Value(..) 26 | , StringValue(..) 27 | , ListValue(..) 28 | , ObjectValue(..) 29 | , ObjectField(..) 30 | , DefaultValue 31 | , Directive(..) 32 | , GType(..) 33 | , NamedType(..) 34 | , ListType(..) 35 | , NonNullType(..) 36 | , TypeDefinition(..) 37 | , ObjectTypeDefinition(..) 38 | , Interfaces 39 | , FieldDefinition(..) 40 | , ArgumentsDefinition 41 | , InputValueDefinition(..) 42 | , InterfaceTypeDefinition(..) 43 | , UnionTypeDefinition(..) 44 | , ScalarTypeDefinition(..) 45 | , EnumTypeDefinition(..) 46 | , EnumValueDefinition(..) 47 | , InputObjectTypeDefinition(..) 48 | , TypeExtensionDefinition(..) 49 | ) where 50 | 51 | import Protolude 52 | 53 | import Test.QuickCheck (Arbitrary(..), listOf, oneof) 54 | 55 | import GraphQL.Internal.Arbitrary (arbitraryText) 56 | import GraphQL.Internal.Name 57 | ( Name 58 | , HasName(..) 59 | ) 60 | 61 | -- * Documents 62 | 63 | -- | A 'QueryDocument' is something a user might send us. 64 | -- 65 | -- https://facebook.github.io/graphql/#sec-Language.Query-Document 66 | newtype QueryDocument = QueryDocument { getDefinitions :: [Definition] } deriving (Eq,Show) 67 | 68 | data Definition = DefinitionOperation OperationDefinition 69 | | DefinitionFragment FragmentDefinition 70 | deriving (Eq,Show) 71 | 72 | -- | A 'SchemaDocument' is a document that defines a GraphQL schema. 73 | -- 74 | -- https://facebook.github.io/graphql/#sec-Type-System 75 | newtype SchemaDocument = SchemaDocument [TypeDefinition] deriving (Eq, Show) 76 | 77 | data OperationDefinition 78 | = Query Node 79 | | Mutation Node 80 | | AnonymousQuery SelectionSet 81 | deriving (Eq,Show) 82 | 83 | data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet 84 | deriving (Eq,Show) 85 | 86 | data VariableDefinition = VariableDefinition Variable GType (Maybe DefaultValue) 87 | deriving (Eq,Show) 88 | 89 | newtype Variable = Variable Name deriving (Eq, Ord, Show) 90 | 91 | instance Arbitrary Variable where 92 | arbitrary = Variable <$> arbitrary 93 | 94 | type SelectionSet = [Selection] 95 | 96 | data Selection = SelectionField Field 97 | | SelectionFragmentSpread FragmentSpread 98 | | SelectionInlineFragment InlineFragment 99 | deriving (Eq,Show) 100 | 101 | data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSet 102 | deriving (Eq,Show) 103 | 104 | type Alias = Name 105 | 106 | data Argument = Argument Name Value deriving (Eq,Show) 107 | 108 | -- * Fragments 109 | 110 | data FragmentSpread = FragmentSpread Name [Directive] 111 | deriving (Eq,Show) 112 | 113 | data InlineFragment = 114 | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet 115 | deriving (Eq,Show) 116 | 117 | data FragmentDefinition = 118 | FragmentDefinition Name TypeCondition [Directive] SelectionSet 119 | deriving (Eq,Show) 120 | 121 | type TypeCondition = NamedType 122 | 123 | -- * Values 124 | 125 | data Value = ValueVariable Variable 126 | | ValueInt Int32 127 | -- GraphQL Float is double precison 128 | | ValueFloat Double 129 | | ValueBoolean Bool 130 | | ValueString StringValue 131 | | ValueEnum Name 132 | | ValueList ListValue 133 | | ValueObject ObjectValue 134 | | ValueNull 135 | deriving (Eq, Show) 136 | 137 | instance Arbitrary Value where 138 | arbitrary = oneof [ ValueVariable <$> arbitrary 139 | , ValueInt <$> arbitrary 140 | , ValueFloat <$> arbitrary 141 | , ValueBoolean <$> arbitrary 142 | , ValueString <$> arbitrary 143 | , ValueEnum <$> arbitrary 144 | , ValueList <$> arbitrary 145 | , ValueObject <$> arbitrary 146 | , pure ValueNull 147 | ] 148 | 149 | newtype StringValue = StringValue Text deriving (Eq,Show) 150 | 151 | instance Arbitrary StringValue where 152 | arbitrary = StringValue <$> arbitraryText 153 | 154 | newtype ListValue = ListValue [Value] deriving (Eq,Show) 155 | 156 | instance Arbitrary ListValue where 157 | arbitrary = ListValue <$> listOf arbitrary 158 | 159 | newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show) 160 | 161 | instance Arbitrary ObjectValue where 162 | arbitrary = ObjectValue <$> listOf arbitrary 163 | 164 | data ObjectField = ObjectField Name Value deriving (Eq,Show) 165 | 166 | instance Arbitrary ObjectField where 167 | arbitrary = ObjectField <$> arbitrary <*> arbitrary 168 | 169 | type DefaultValue = Value 170 | 171 | -- * Directives 172 | 173 | data Directive = Directive Name [Argument] deriving (Eq,Show) 174 | 175 | -- * Type Reference 176 | 177 | data GType = TypeNamed NamedType 178 | | TypeList ListType 179 | | TypeNonNull NonNullType 180 | deriving (Eq, Ord, Show) 181 | 182 | -- | Get the name of the given 'GType'. 183 | instance HasName GType where 184 | getName (TypeNamed (NamedType n)) = n 185 | getName (TypeList (ListType t)) = getName t 186 | getName (TypeNonNull (NonNullTypeNamed (NamedType n))) = n 187 | getName (TypeNonNull (NonNullTypeList (ListType l))) = getName l 188 | 189 | newtype NamedType = NamedType Name deriving (Eq, Ord, Show) 190 | 191 | newtype ListType = ListType GType deriving (Eq, Ord, Show) 192 | 193 | data NonNullType = NonNullTypeNamed NamedType 194 | | NonNullTypeList ListType 195 | deriving (Eq, Ord, Show) 196 | 197 | -- * Type definition 198 | 199 | data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition 200 | | TypeDefinitionInterface InterfaceTypeDefinition 201 | | TypeDefinitionUnion UnionTypeDefinition 202 | | TypeDefinitionScalar ScalarTypeDefinition 203 | | TypeDefinitionEnum EnumTypeDefinition 204 | | TypeDefinitionInputObject InputObjectTypeDefinition 205 | | TypeDefinitionTypeExtension TypeExtensionDefinition 206 | deriving (Eq,Show) 207 | 208 | data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition] 209 | deriving (Eq,Show) 210 | 211 | type Interfaces = [NamedType] 212 | 213 | data FieldDefinition = FieldDefinition Name ArgumentsDefinition GType 214 | deriving (Eq,Show) 215 | 216 | type ArgumentsDefinition = [InputValueDefinition] 217 | 218 | data InputValueDefinition = InputValueDefinition Name GType (Maybe DefaultValue) 219 | deriving (Eq,Show) 220 | 221 | data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition] 222 | deriving (Eq,Show) 223 | 224 | data UnionTypeDefinition = UnionTypeDefinition Name [NamedType] 225 | deriving (Eq,Show) 226 | 227 | newtype ScalarTypeDefinition = ScalarTypeDefinition Name 228 | deriving (Eq,Show) 229 | 230 | data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] 231 | deriving (Eq,Show) 232 | 233 | newtype EnumValueDefinition = EnumValueDefinition Name 234 | deriving (Eq,Show) 235 | 236 | data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition] 237 | deriving (Eq,Show) 238 | 239 | newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition 240 | deriving (Eq,Show) 241 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Syntax/Encoder.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Description: Turn GraphQL ASTs into text 4 | module GraphQL.Internal.Syntax.Encoder 5 | ( queryDocument 6 | , schemaDocument 7 | , value 8 | ) where 9 | 10 | import Protolude hiding (intercalate) 11 | 12 | import qualified Data.Aeson as Aeson 13 | import Data.Text (Text, cons, intercalate, pack, snoc) 14 | 15 | import qualified GraphQL.Internal.Syntax.AST as AST 16 | import GraphQL.Internal.Name (unName) 17 | 18 | -- * Document 19 | 20 | queryDocument :: AST.QueryDocument -> Text 21 | queryDocument (AST.QueryDocument defs) = (`snoc` '\n') . mconcat $ definition <$> defs 22 | 23 | definition :: AST.Definition -> Text 24 | definition (AST.DefinitionOperation x) = operationDefinition x 25 | definition (AST.DefinitionFragment x) = fragmentDefinition x 26 | 27 | schemaDocument :: AST.SchemaDocument -> Text 28 | schemaDocument (AST.SchemaDocument defs) = (`snoc` '\n') . mconcat $ typeDefinition <$> defs 29 | 30 | operationDefinition :: AST.OperationDefinition -> Text 31 | operationDefinition (AST.Query n) = "query " <> node n 32 | operationDefinition (AST.Mutation n) = "mutation " <> node n 33 | operationDefinition (AST.AnonymousQuery ss) = selectionSet ss 34 | 35 | node :: AST.Node -> Text 36 | node (AST.Node (Just name) vds ds ss) = 37 | unName name 38 | <> optempty variableDefinitions vds 39 | <> optempty directives ds 40 | <> selectionSet ss 41 | node (AST.Node Nothing vds ds ss) = 42 | optempty variableDefinitions vds 43 | <> optempty directives ds 44 | <> selectionSet ss 45 | 46 | variableDefinitions :: [AST.VariableDefinition] -> Text 47 | variableDefinitions = parensCommas variableDefinition 48 | 49 | variableDefinition :: AST.VariableDefinition -> Text 50 | variableDefinition (AST.VariableDefinition var ty dv) = 51 | variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv 52 | 53 | defaultValue :: AST.DefaultValue -> Text 54 | defaultValue val = "=" <> value val 55 | 56 | variable :: AST.Variable -> Text 57 | variable (AST.Variable name) = "$" <> unName name 58 | 59 | selectionSet :: AST.SelectionSet -> Text 60 | selectionSet = bracesCommas selection 61 | 62 | selection :: AST.Selection -> Text 63 | selection (AST.SelectionField x) = field x 64 | selection (AST.SelectionInlineFragment x) = inlineFragment x 65 | selection (AST.SelectionFragmentSpread x) = fragmentSpread x 66 | 67 | field :: AST.Field -> Text 68 | field (AST.Field alias name args ds ss) = 69 | optempty (`snoc` ':') (maybe mempty unName alias) 70 | <> unName name 71 | <> optempty arguments args 72 | <> optempty directives ds 73 | <> optempty selectionSet ss 74 | 75 | arguments :: [AST.Argument] -> Text 76 | arguments = parensCommas argument 77 | 78 | argument :: AST.Argument -> Text 79 | argument (AST.Argument name v) = unName name <> ":" <> value v 80 | 81 | -- * Fragments 82 | 83 | fragmentSpread :: AST.FragmentSpread -> Text 84 | fragmentSpread (AST.FragmentSpread name ds) = 85 | "..." <> unName name <> optempty directives ds 86 | 87 | inlineFragment :: AST.InlineFragment -> Text 88 | inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) = 89 | "... on " <> unName tc 90 | <> optempty directives ds 91 | <> optempty selectionSet ss 92 | inlineFragment (AST.InlineFragment Nothing ds ss) = 93 | "... " <> optempty directives ds 94 | <> optempty selectionSet ss 95 | 96 | fragmentDefinition :: AST.FragmentDefinition -> Text 97 | fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) = 98 | "fragment " <> unName name <> " on " <> unName tc 99 | <> optempty directives ds 100 | <> selectionSet ss 101 | 102 | -- * Values 103 | 104 | value :: AST.Value -> Text 105 | value (AST.ValueVariable x) = variable x 106 | -- TODO: This will be replaced with `decimal` Buidler 107 | value (AST.ValueInt x) = pack $ show x 108 | -- TODO: This will be replaced with `decimal` Buidler 109 | value (AST.ValueFloat x) = pack $ show x 110 | value (AST.ValueBoolean x) = booleanValue x 111 | value (AST.ValueString x) = stringValue x 112 | value (AST.ValueEnum x) = unName x 113 | value (AST.ValueList x) = listValue x 114 | value (AST.ValueObject x) = objectValue x 115 | value AST.ValueNull = "null" 116 | 117 | booleanValue :: Bool -> Text 118 | booleanValue True = "true" 119 | booleanValue False = "false" 120 | 121 | -- TODO: Escape characters 122 | stringValue :: AST.StringValue -> Text 123 | stringValue (AST.StringValue v) = toS $ Aeson.encode v 124 | 125 | listValue :: AST.ListValue -> Text 126 | listValue (AST.ListValue vs) = bracketsCommas value vs 127 | 128 | objectValue :: AST.ObjectValue -> Text 129 | objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs 130 | 131 | objectField :: AST.ObjectField -> Text 132 | objectField (AST.ObjectField name v) = unName name <> ":" <> value v 133 | 134 | -- * Directives 135 | 136 | directives :: [AST.Directive] -> Text 137 | directives = spaces directive 138 | 139 | directive :: AST.Directive -> Text 140 | directive (AST.Directive name args) = "@" <> unName name <> optempty arguments args 141 | 142 | -- * Type Reference 143 | 144 | type_ :: AST.GType -> Text 145 | type_ (AST.TypeNamed (AST.NamedType x)) = unName x 146 | type_ (AST.TypeList x) = listType x 147 | type_ (AST.TypeNonNull x) = nonNullType x 148 | 149 | namedType :: AST.NamedType -> Text 150 | namedType (AST.NamedType name) = unName name 151 | 152 | listType :: AST.ListType -> Text 153 | listType (AST.ListType ty) = brackets (type_ ty) 154 | 155 | nonNullType :: AST.NonNullType -> Text 156 | nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = unName x <> "!" 157 | nonNullType (AST.NonNullTypeList x) = listType x <> "!" 158 | 159 | typeDefinition :: AST.TypeDefinition -> Text 160 | typeDefinition (AST.TypeDefinitionObject x) = objectTypeDefinition x 161 | typeDefinition (AST.TypeDefinitionInterface x) = interfaceTypeDefinition x 162 | typeDefinition (AST.TypeDefinitionUnion x) = unionTypeDefinition x 163 | typeDefinition (AST.TypeDefinitionScalar x) = scalarTypeDefinition x 164 | typeDefinition (AST.TypeDefinitionEnum x) = enumTypeDefinition x 165 | typeDefinition (AST.TypeDefinitionInputObject x) = inputObjectTypeDefinition x 166 | typeDefinition (AST.TypeDefinitionTypeExtension x) = typeExtensionDefinition x 167 | 168 | objectTypeDefinition :: AST.ObjectTypeDefinition -> Text 169 | objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) = 170 | "type " <> unName name 171 | <> optempty (spaced . interfaces) ifaces 172 | <> optempty fieldDefinitions fds 173 | 174 | interfaces :: AST.Interfaces -> Text 175 | interfaces = ("implements " <>) . spaces namedType 176 | 177 | fieldDefinitions :: [AST.FieldDefinition] -> Text 178 | fieldDefinitions = bracesCommas fieldDefinition 179 | 180 | fieldDefinition :: AST.FieldDefinition -> Text 181 | fieldDefinition (AST.FieldDefinition name args ty) = 182 | unName name <> optempty argumentsDefinition args 183 | <> ":" 184 | <> type_ ty 185 | 186 | argumentsDefinition :: AST.ArgumentsDefinition -> Text 187 | argumentsDefinition = parensCommas inputValueDefinition 188 | 189 | interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text 190 | interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) = 191 | "interface " <> unName name <> fieldDefinitions fds 192 | 193 | unionTypeDefinition :: AST.UnionTypeDefinition -> Text 194 | unionTypeDefinition (AST.UnionTypeDefinition name ums) = 195 | "union " <> unName name <> "=" <> unionMembers ums 196 | 197 | unionMembers :: [AST.NamedType] -> Text 198 | unionMembers = intercalate "|" . fmap namedType 199 | 200 | scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text 201 | scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> unName name 202 | 203 | enumTypeDefinition :: AST.EnumTypeDefinition -> Text 204 | enumTypeDefinition (AST.EnumTypeDefinition name evds) = 205 | "enum " <> unName name 206 | <> bracesCommas enumValueDefinition evds 207 | 208 | enumValueDefinition :: AST.EnumValueDefinition -> Text 209 | enumValueDefinition (AST.EnumValueDefinition name) = unName name 210 | 211 | inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text 212 | inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) = 213 | "input " <> unName name <> inputValueDefinitions ivds 214 | 215 | inputValueDefinitions :: [AST.InputValueDefinition] -> Text 216 | inputValueDefinitions = bracesCommas inputValueDefinition 217 | 218 | inputValueDefinition :: AST.InputValueDefinition -> Text 219 | inputValueDefinition (AST.InputValueDefinition name ty dv) = 220 | unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv 221 | 222 | typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text 223 | typeExtensionDefinition (AST.TypeExtensionDefinition otd) = 224 | "extend " <> objectTypeDefinition otd 225 | 226 | -- * Internal 227 | 228 | spaced :: Text -> Text 229 | spaced = cons '\SP' 230 | 231 | between :: Char -> Char -> Text -> Text 232 | between open close = cons open . (`snoc` close) 233 | 234 | parens :: Text -> Text 235 | parens = between '(' ')' 236 | 237 | brackets :: Text -> Text 238 | brackets = between '[' ']' 239 | 240 | braces :: Text -> Text 241 | braces = between '{' '}' 242 | 243 | spaces :: (a -> Text) -> [a] -> Text 244 | spaces f = intercalate "\SP" . fmap f 245 | 246 | parensCommas :: (a -> Text) -> [a] -> Text 247 | parensCommas f = parens . intercalate "," . fmap f 248 | 249 | bracketsCommas :: (a -> Text) -> [a] -> Text 250 | bracketsCommas f = brackets . intercalate "," . fmap f 251 | 252 | bracesCommas :: (a -> Text) -> [a] -> Text 253 | bracesCommas f = braces . intercalate "," . fmap f 254 | 255 | optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b 256 | optempty f xs = if xs == mempty then mempty else f xs 257 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Syntax/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | 4 | -- | Description: Parse text into GraphQL ASTs 5 | module GraphQL.Internal.Syntax.Parser 6 | ( queryDocument 7 | , schemaDocument 8 | , value 9 | ) where 10 | 11 | import Protolude hiding (option) 12 | 13 | import Control.Applicative ((<|>), empty, many, optional) 14 | import Control.Monad (fail) 15 | import Data.Aeson.Parser (jstring) 16 | import Data.Scientific (floatingOrInteger) 17 | import Data.Text (find) 18 | import qualified Data.Attoparsec.ByteString as A 19 | import Data.Attoparsec.Text 20 | ( Parser 21 | , () 22 | , anyChar 23 | , char 24 | , match 25 | , many1 26 | , option 27 | , scan 28 | , scientific 29 | , sepBy1 30 | ) 31 | 32 | import qualified GraphQL.Internal.Syntax.AST as AST 33 | import GraphQL.Internal.Syntax.Tokens (tok, whiteSpace) 34 | import GraphQL.Internal.Name (nameParser) 35 | 36 | -- * Document 37 | 38 | queryDocument :: Parser AST.QueryDocument 39 | queryDocument = whiteSpace *> (AST.QueryDocument <$> many1 definition) "query document error!" 40 | 41 | -- | Parser for a schema document. 42 | schemaDocument :: Parser AST.SchemaDocument 43 | schemaDocument = whiteSpace *> (AST.SchemaDocument <$> many1 typeDefinition) "type document error" 44 | 45 | definition :: Parser AST.Definition 46 | definition = AST.DefinitionOperation <$> operationDefinition 47 | <|> AST.DefinitionFragment <$> fragmentDefinition 48 | "definition error!" 49 | 50 | operationDefinition :: Parser AST.OperationDefinition 51 | operationDefinition = 52 | AST.Query <$ tok "query" <*> node 53 | <|> AST.Mutation <$ tok "mutation" <*> node 54 | <|> (AST.AnonymousQuery <$> selectionSet) 55 | "operationDefinition error!" 56 | 57 | node :: Parser AST.Node 58 | node = AST.Node <$> optional nameParser 59 | <*> optempty variableDefinitions 60 | <*> optempty directives 61 | <*> selectionSet 62 | 63 | variableDefinitions :: Parser [AST.VariableDefinition] 64 | variableDefinitions = parens (many1 variableDefinition) 65 | 66 | variableDefinition :: Parser AST.VariableDefinition 67 | variableDefinition = 68 | AST.VariableDefinition <$> variable 69 | <* tok ":" 70 | <*> type_ 71 | <*> optional defaultValue 72 | 73 | defaultValue :: Parser AST.DefaultValue 74 | defaultValue = tok "=" *> value 75 | 76 | variable :: Parser AST.Variable 77 | variable = AST.Variable <$ tok "$" <*> nameParser 78 | 79 | selectionSet :: Parser AST.SelectionSet 80 | selectionSet = braces $ many1 selection 81 | 82 | selection :: Parser AST.Selection 83 | selection = AST.SelectionField <$> field 84 | -- Inline first to catch `on` case 85 | <|> AST.SelectionInlineFragment <$> inlineFragment 86 | <|> AST.SelectionFragmentSpread <$> fragmentSpread 87 | "selection error!" 88 | 89 | field :: Parser AST.Field 90 | field = AST.Field <$> option empty (pure <$> alias) 91 | <*> nameParser 92 | <*> optempty arguments 93 | <*> optempty directives 94 | <*> optempty selectionSet 95 | 96 | alias :: Parser AST.Alias 97 | alias = nameParser <* tok ":" 98 | 99 | arguments :: Parser [AST.Argument] 100 | arguments = parens $ many1 argument 101 | 102 | argument :: Parser AST.Argument 103 | argument = AST.Argument <$> nameParser <* tok ":" <*> value 104 | 105 | -- * Fragments 106 | 107 | fragmentSpread :: Parser AST.FragmentSpread 108 | -- TODO: Make sure it fails when `... on`. 109 | -- See https://facebook.github.io/graphql/#FragmentSpread 110 | fragmentSpread = AST.FragmentSpread 111 | <$ tok "..." 112 | <*> nameParser 113 | <*> optempty directives 114 | 115 | -- InlineFragment tried first in order to guard against 'on' keyword 116 | inlineFragment :: Parser AST.InlineFragment 117 | inlineFragment = AST.InlineFragment 118 | <$ tok "..." 119 | <*> optional (tok "on" *> typeCondition) 120 | <*> optempty directives 121 | <*> selectionSet 122 | 123 | fragmentDefinition :: Parser AST.FragmentDefinition 124 | fragmentDefinition = AST.FragmentDefinition 125 | <$ tok "fragment" 126 | <*> nameParser 127 | <* tok "on" 128 | <*> typeCondition 129 | <*> optempty directives 130 | <*> selectionSet 131 | 132 | typeCondition :: Parser AST.TypeCondition 133 | typeCondition = namedType 134 | 135 | -- * Values 136 | 137 | -- This will try to pick the first type it can parse. If you are working with 138 | -- explicit types use the `typedValue` parser. 139 | value :: Parser AST.Value 140 | value = tok (AST.ValueVariable <$> (variable "variable") 141 | <|> (number "number") 142 | <|> AST.ValueNull <$ tok "null" 143 | <|> AST.ValueBoolean <$> (booleanValue "booleanValue") 144 | <|> AST.ValueString <$> (stringValue "stringValue") 145 | -- `true` and `false` have been tried before 146 | <|> AST.ValueEnum <$> (nameParser "name") 147 | <|> AST.ValueList <$> (listValue "listValue") 148 | <|> AST.ValueObject <$> (objectValue "objectValue") 149 | "value error!") 150 | where 151 | number = do 152 | (numText, num) <- match (tok scientific) 153 | case (Data.Text.find (== '.') numText, floatingOrInteger num) of 154 | (Just _, Left r) -> pure (AST.ValueFloat r) 155 | (Just _, Right i) -> pure (AST.ValueFloat (fromIntegral i)) 156 | -- TODO: Handle maxBound, Int32 in spec. 157 | (Nothing, Left r) -> pure (AST.ValueInt (floor r)) 158 | (Nothing, Right i) -> pure (AST.ValueInt i) 159 | 160 | booleanValue :: Parser Bool 161 | booleanValue = True <$ tok "true" 162 | <|> False <$ tok "false" 163 | 164 | stringValue :: Parser AST.StringValue 165 | stringValue = do 166 | parsed <- char '"' *> jstring_ 167 | case unescapeText parsed of 168 | Left err -> fail err 169 | Right escaped -> pure (AST.StringValue escaped) 170 | where 171 | -- | Parse a string without a leading quote, ignoring any escaped characters. 172 | jstring_ :: Parser Text 173 | jstring_ = scan startState go <* anyChar 174 | 175 | startState = False 176 | go a c 177 | | a = Just False 178 | | c == '"' = Nothing 179 | | otherwise = let a' = c == backslash 180 | in Just a' 181 | where backslash = '\\' 182 | 183 | -- | Unescape a string. 184 | -- 185 | -- Turns out this is really tricky, so we're going to cheat by 186 | -- reconstructing a literal string (by putting quotes around it) and 187 | -- delegating all the hard work to Aeson. 188 | unescapeText str = A.parseOnly jstring ("\"" <> toS str <> "\"") 189 | 190 | -- Notice it can be empty 191 | listValue :: Parser AST.ListValue 192 | listValue = AST.ListValue <$> brackets (many value) 193 | 194 | -- Notice it can be empty 195 | objectValue :: Parser AST.ObjectValue 196 | objectValue = AST.ObjectValue <$> braces (many (objectField "objectField")) 197 | 198 | objectField :: Parser AST.ObjectField 199 | objectField = AST.ObjectField <$> nameParser <* tok ":" <*> value 200 | 201 | -- * Directives 202 | 203 | directives :: Parser [AST.Directive] 204 | directives = many1 directive 205 | 206 | directive :: Parser AST.Directive 207 | directive = AST.Directive 208 | <$ tok "@" 209 | <*> nameParser 210 | <*> optempty arguments 211 | 212 | -- * Type Reference 213 | 214 | type_ :: Parser AST.GType 215 | type_ = AST.TypeList <$> listType 216 | <|> AST.TypeNonNull <$> nonNullType 217 | <|> AST.TypeNamed <$> namedType 218 | "type_ error!" 219 | 220 | namedType :: Parser AST.NamedType 221 | namedType = AST.NamedType <$> nameParser 222 | 223 | listType :: Parser AST.ListType 224 | listType = AST.ListType <$> brackets type_ 225 | 226 | nonNullType :: Parser AST.NonNullType 227 | nonNullType = AST.NonNullTypeNamed <$> namedType <* tok "!" 228 | <|> AST.NonNullTypeList <$> listType <* tok "!" 229 | "nonNullType error!" 230 | 231 | -- * Type Definition 232 | 233 | typeDefinition :: Parser AST.TypeDefinition 234 | typeDefinition = 235 | AST.TypeDefinitionObject <$> objectTypeDefinition 236 | <|> AST.TypeDefinitionInterface <$> interfaceTypeDefinition 237 | <|> AST.TypeDefinitionUnion <$> unionTypeDefinition 238 | <|> AST.TypeDefinitionScalar <$> scalarTypeDefinition 239 | <|> AST.TypeDefinitionEnum <$> enumTypeDefinition 240 | <|> AST.TypeDefinitionInputObject <$> inputObjectTypeDefinition 241 | <|> AST.TypeDefinitionTypeExtension <$> typeExtensionDefinition 242 | "typeDefinition error!" 243 | 244 | objectTypeDefinition :: Parser AST.ObjectTypeDefinition 245 | objectTypeDefinition = AST.ObjectTypeDefinition 246 | <$ tok "type" 247 | <*> nameParser 248 | <*> optempty interfaces 249 | <*> fieldDefinitions 250 | 251 | interfaces :: Parser AST.Interfaces 252 | interfaces = tok "implements" *> many1 namedType 253 | 254 | fieldDefinitions :: Parser [AST.FieldDefinition] 255 | fieldDefinitions = braces $ many1 fieldDefinition 256 | 257 | fieldDefinition :: Parser AST.FieldDefinition 258 | fieldDefinition = AST.FieldDefinition 259 | <$> nameParser 260 | <*> optempty argumentsDefinition 261 | <* tok ":" 262 | <*> type_ 263 | 264 | argumentsDefinition :: Parser AST.ArgumentsDefinition 265 | argumentsDefinition = parens $ many1 inputValueDefinition 266 | 267 | interfaceTypeDefinition :: Parser AST.InterfaceTypeDefinition 268 | interfaceTypeDefinition = AST.InterfaceTypeDefinition 269 | <$ tok "interface" 270 | <*> nameParser 271 | <*> fieldDefinitions 272 | 273 | unionTypeDefinition :: Parser AST.UnionTypeDefinition 274 | unionTypeDefinition = AST.UnionTypeDefinition 275 | <$ tok "union" 276 | <*> nameParser 277 | <* tok "=" 278 | <*> unionMembers 279 | 280 | unionMembers :: Parser [AST.NamedType] 281 | unionMembers = namedType `sepBy1` tok "|" 282 | 283 | scalarTypeDefinition :: Parser AST.ScalarTypeDefinition 284 | scalarTypeDefinition = AST.ScalarTypeDefinition 285 | <$ tok "scalar" 286 | <*> nameParser 287 | 288 | enumTypeDefinition :: Parser AST.EnumTypeDefinition 289 | enumTypeDefinition = AST.EnumTypeDefinition 290 | <$ tok "enum" 291 | <*> nameParser 292 | <*> enumValueDefinitions 293 | 294 | enumValueDefinitions :: Parser [AST.EnumValueDefinition] 295 | enumValueDefinitions = braces $ many1 enumValueDefinition 296 | 297 | enumValueDefinition :: Parser AST.EnumValueDefinition 298 | enumValueDefinition = AST.EnumValueDefinition <$> nameParser 299 | 300 | inputObjectTypeDefinition :: Parser AST.InputObjectTypeDefinition 301 | inputObjectTypeDefinition = AST.InputObjectTypeDefinition 302 | <$ tok "input" 303 | <*> nameParser 304 | <*> inputValueDefinitions 305 | 306 | inputValueDefinitions :: Parser [AST.InputValueDefinition] 307 | inputValueDefinitions = braces $ many1 inputValueDefinition 308 | 309 | inputValueDefinition :: Parser AST.InputValueDefinition 310 | inputValueDefinition = AST.InputValueDefinition 311 | <$> nameParser 312 | <* tok ":" 313 | <*> type_ 314 | <*> optional defaultValue 315 | 316 | typeExtensionDefinition :: Parser AST.TypeExtensionDefinition 317 | typeExtensionDefinition = AST.TypeExtensionDefinition 318 | <$ tok "extend" 319 | <*> objectTypeDefinition 320 | 321 | -- * Internal 322 | 323 | parens :: Parser a -> Parser a 324 | parens = between "(" ")" 325 | 326 | braces :: Parser a -> Parser a 327 | braces = between "{" "}" 328 | 329 | brackets :: Parser a -> Parser a 330 | brackets = between "[" "]" 331 | 332 | between :: Parser Text -> Parser Text -> Parser a -> Parser a 333 | between open close p = tok open *> p <* tok close 334 | 335 | -- `empty` /= `pure mempty` for `Parser`. 336 | optempty :: Monoid a => Parser a -> Parser a 337 | optempty = option mempty 338 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Syntax/Tokens.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Description: Basic tokenising used by parser 4 | module GraphQL.Internal.Syntax.Tokens 5 | ( tok 6 | , whiteSpace 7 | ) where 8 | 9 | import Protolude 10 | import Data.Attoparsec.Text 11 | ( Parser 12 | , anyChar 13 | , endOfLine 14 | , peekChar 15 | , manyTill 16 | ) 17 | import Data.Char (isSpace) 18 | 19 | tok :: Parser a -> Parser a 20 | tok p = p <* whiteSpace 21 | 22 | whiteSpace :: Parser () 23 | whiteSpace = peekChar >>= traverse_ (\c -> 24 | if isSpace c || c == ',' 25 | then anyChar *> whiteSpace 26 | else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace) 27 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# OPTIONS_HADDOCK not-home #-} 11 | 12 | -- | Description: Literal GraphQL values 13 | module GraphQL.Internal.Value 14 | ( Value 15 | , Value'(..) 16 | , ConstScalar 17 | , UnresolvedVariableValue 18 | , pattern ValueInt 19 | , pattern ValueFloat 20 | , pattern ValueBoolean 21 | , pattern ValueString 22 | , pattern ValueEnum 23 | , pattern ValueList 24 | , pattern ValueObject 25 | , pattern ValueNull 26 | , toObject 27 | , valueToAST 28 | , astToVariableValue 29 | , variableValueToAST 30 | , List 31 | , List'(..) 32 | , String(..) 33 | -- * Names 34 | , Name(..) 35 | , NameError(..) 36 | , makeName 37 | -- * Objects 38 | , Object 39 | , Object'(..) 40 | , ObjectField 41 | , ObjectField'(ObjectField) 42 | -- ** Constructing 43 | , makeObject 44 | , objectFromList 45 | , objectFromOrderedMap 46 | -- ** Combining 47 | , unionObjects 48 | -- ** Querying 49 | , objectFields 50 | ) where 51 | 52 | import Protolude 53 | 54 | import qualified Data.Aeson as Aeson 55 | import Data.Aeson (ToJSON(..), (.=), pairs) 56 | import qualified Data.Map as Map 57 | import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized) 58 | 59 | import GraphQL.Internal.Arbitrary (arbitraryText) 60 | import GraphQL.Internal.Name (Name(..), NameError(..), makeName) 61 | import GraphQL.Internal.Syntax.AST (Variable) 62 | import qualified GraphQL.Internal.Syntax.AST as AST 63 | import GraphQL.Internal.OrderedMap (OrderedMap) 64 | import qualified GraphQL.Internal.OrderedMap as OrderedMap 65 | 66 | -- * Values 67 | 68 | -- | A GraphQL value. @scalar@ represents the type of scalar that's contained 69 | -- within this value. 70 | -- 71 | -- Normally, it is one of either 'ConstScalar' (to indicate that there are no 72 | -- variables whatsoever) or 'VariableScalar' (to indicate that there might be 73 | -- some variables). 74 | data Value' scalar 75 | = ValueScalar' scalar 76 | | ValueList' (List' scalar) 77 | | ValueObject' (Object' scalar) 78 | deriving (Eq, Ord, Show, Functor) 79 | 80 | instance Foldable Value' where 81 | foldMap f (ValueScalar' scalar) = f scalar 82 | foldMap f (ValueList' values) = foldMap f values 83 | foldMap f (ValueObject' obj) = foldMap f obj 84 | 85 | instance Traversable Value' where 86 | traverse f (ValueScalar' x) = ValueScalar' <$> f x 87 | traverse f (ValueList' xs) = ValueList' <$> traverse f xs 88 | traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs 89 | 90 | instance ToJSON scalar => ToJSON (Value' scalar) where 91 | toJSON (ValueScalar' x) = toJSON x 92 | toJSON (ValueList' x) = toJSON x 93 | toJSON (ValueObject' x) = toJSON x 94 | 95 | instance Arbitrary scalar => Arbitrary (Value' scalar) where 96 | -- | Generate an arbitrary value. Uses the generator's \"size\" property to 97 | -- determine maximum object depth. 98 | arbitrary = sized genValue 99 | 100 | -- | Generate an arbitrary value, with objects at most @n@ levels deep. 101 | genValue :: Arbitrary scalar => Int -> Gen (Value' scalar) 102 | genValue n 103 | | n <= 0 = arbitrary 104 | | otherwise = oneof [ ValueScalar' <$> arbitrary 105 | , ValueObject' <$> genObject (n - 1) 106 | , ValueList' . List' <$> listOf (genValue (n - 1)) 107 | ] 108 | 109 | -- | A GraphQL value which contains no variables. 110 | type Value = Value' ConstScalar 111 | 112 | -- TODO: These next two definitions are quite internal. We should move this 113 | -- module to Internal and then re-export the bits that end-users will use. 114 | -- 115 | 116 | -- | A GraphQL value which might contain some variables. These variables are 117 | -- not yet associated with 118 | -- (see also 'GraphQL.Internal.Validation.VariableDefinition'), 120 | -- which are provided in a different context. 121 | type UnresolvedVariableValue = Value' UnresolvedVariableScalar 122 | 123 | pattern ValueInt :: Int32 -> Value 124 | pattern ValueInt x = ValueScalar' (ConstInt x) 125 | 126 | pattern ValueFloat :: Double -> Value 127 | pattern ValueFloat x = ValueScalar' (ConstFloat x) 128 | 129 | pattern ValueBoolean :: Bool -> Value 130 | pattern ValueBoolean x = ValueScalar' (ConstBoolean x) 131 | 132 | pattern ValueString :: String -> Value 133 | pattern ValueString x = ValueScalar' (ConstString x) 134 | 135 | pattern ValueEnum :: Name -> Value 136 | pattern ValueEnum x = ValueScalar' (ConstEnum x) 137 | 138 | pattern ValueList :: forall t. List' t -> Value' t 139 | pattern ValueList x = ValueList' x 140 | 141 | pattern ValueObject :: forall t. Object' t -> Value' t 142 | pattern ValueObject x = ValueObject' x 143 | 144 | pattern ValueNull :: Value 145 | pattern ValueNull = ValueScalar' ConstNull 146 | 147 | -- | If a value is an object, return just that. Otherwise @Nothing@. 148 | toObject :: Value' scalar -> Maybe (Object' scalar) 149 | toObject (ValueObject' o) = pure o 150 | toObject _ = empty 151 | 152 | -- * Scalars 153 | 154 | -- | A non-variable value which contains no other values. 155 | data ConstScalar 156 | = ConstInt Int32 157 | | ConstFloat Double 158 | | ConstBoolean Bool 159 | | ConstString String 160 | | ConstEnum Name 161 | | ConstNull 162 | deriving (Eq, Ord, Show) 163 | 164 | instance ToJSON ConstScalar where 165 | toJSON (ConstInt x) = toJSON x 166 | toJSON (ConstFloat x) = toJSON x 167 | toJSON (ConstBoolean x) = toJSON x 168 | toJSON (ConstString x) = toJSON x 169 | toJSON (ConstEnum x) = toJSON x 170 | toJSON ConstNull = Aeson.Null 171 | 172 | -- | A value which contains no other values, and might be a variable that 173 | -- might lack a definition. 174 | type UnresolvedVariableScalar = Either Variable ConstScalar 175 | 176 | -- | Generate an arbitrary scalar value. 177 | instance Arbitrary ConstScalar where 178 | arbitrary = oneof [ ConstInt <$> arbitrary 179 | , ConstFloat <$> arbitrary 180 | , ConstBoolean <$> arbitrary 181 | , ConstString <$> arbitrary 182 | , ConstEnum <$> arbitrary 183 | , pure ConstNull 184 | ] 185 | 186 | -- | Convert a constant scalar to an AST.Value 187 | constScalarToAST :: ConstScalar -> AST.Value 188 | constScalarToAST scalar = 189 | case scalar of 190 | ConstInt x -> AST.ValueInt x 191 | ConstFloat x -> AST.ValueFloat x 192 | ConstBoolean x -> AST.ValueBoolean x 193 | ConstString (String x) -> AST.ValueString (AST.StringValue x) 194 | ConstEnum x -> AST.ValueEnum x 195 | ConstNull -> AST.ValueNull 196 | 197 | -- | Convert a variable scalar to an AST.Value 198 | variableToAST :: UnresolvedVariableScalar -> AST.Value 199 | variableToAST (Left variable) = AST.ValueVariable variable 200 | variableToAST (Right constant) = constScalarToAST constant 201 | 202 | -- | Convert a value from the AST into a variable scalar, presuming it /is/ a 203 | -- scalar. 204 | astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar 205 | astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x 206 | astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x 207 | astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x 208 | astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x) 209 | astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x 210 | astToScalar AST.ValueNull = pure $ Right ConstNull 211 | astToScalar (AST.ValueVariable x) = pure $ Left x 212 | astToScalar _ = empty 213 | 214 | 215 | -- * Strings 216 | 217 | newtype String = String Text deriving (Eq, Ord, Show) 218 | 219 | instance Arbitrary String where 220 | arbitrary = String <$> arbitraryText 221 | 222 | instance ToJSON String where 223 | toJSON (String x) = toJSON x 224 | 225 | -- * Lists 226 | 227 | newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor) 228 | 229 | instance Foldable List' where 230 | foldMap f (List' values) = mconcat (map (foldMap f) values) 231 | 232 | instance Traversable List' where 233 | traverse f (List' xs) = List' <$> traverse (traverse f) xs 234 | 235 | 236 | -- | A list of values that are known to be constants. 237 | -- 238 | -- Note that this list might not be valid GraphQL, because GraphQL only allows 239 | -- homogeneous lists (i.e. all elements of the same type), and we do no type 240 | -- checking at this point. 241 | type List = List' ConstScalar 242 | 243 | instance Arbitrary scalar => Arbitrary (List' scalar) where 244 | -- TODO: GraphQL does not allow heterogeneous lists: 245 | -- https://facebook.github.io/graphql/#sec-Lists, so this will generate 246 | -- invalid lists. 247 | arbitrary = List' <$> listOf arbitrary 248 | 249 | 250 | instance ToJSON scalar => ToJSON (List' scalar) where 251 | toJSON (List' x) = toJSON x 252 | 253 | -- * Objects 254 | 255 | -- | A GraphQL object. 256 | -- 257 | -- Note that https://facebook.github.io/graphql/#sec-Response calls these 258 | -- \"Maps\", but everywhere else in the spec refers to them as objects. 259 | newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor) 260 | 261 | instance Foldable Object' where 262 | foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap 263 | 264 | instance Traversable Object' where 265 | traverse f (Object' xs) = Object' <$> traverse (traverse f) xs 266 | 267 | -- | A GraphQL object that contains only non-variable values. 268 | type Object = Object' ConstScalar 269 | 270 | objectFields :: Object' scalar -> [ObjectField' scalar] 271 | objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object) 272 | 273 | instance Arbitrary scalar => Arbitrary (Object' scalar) where 274 | arbitrary = sized genObject 275 | 276 | -- | Generate an arbitrary object to the given maximum depth. 277 | genObject :: Arbitrary scalar => Int -> Gen (Object' scalar) 278 | genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n) 279 | 280 | data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor) 281 | 282 | -- | A field of an object that has a non-variable value. 283 | type ObjectField = ObjectField' ConstScalar 284 | 285 | pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t 286 | pattern ObjectField name value = ObjectField' name value 287 | 288 | instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where 289 | arbitrary = ObjectField' <$> arbitrary <*> arbitrary 290 | 291 | -- | Make an object from a list of object fields. 292 | makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar) 293 | makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields] 294 | 295 | -- | Make an object from an ordered map. 296 | objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar 297 | objectFromOrderedMap = Object' 298 | 299 | -- | Create an object from a list of (name, value) pairs. 300 | objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar) 301 | objectFromList xs = Object' <$> OrderedMap.orderedMap xs 302 | 303 | unionObjects :: [Object' scalar] -> Maybe (Object' scalar) 304 | unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects] 305 | 306 | instance ToJSON scalar => ToJSON (Object' scalar) where 307 | -- Direct encoding to preserve order of keys / values 308 | toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs]) 309 | toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs)) 310 | 311 | 312 | 313 | 314 | -- * Conversion to and from AST. 315 | 316 | -- | Convert an AST value into a literal value. 317 | -- 318 | -- This is a stop-gap until we have proper conversion of user queries into 319 | -- canonical forms. 320 | astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar) 321 | astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x)) 322 | astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x)) 323 | astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x)) 324 | astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x)) 325 | astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x)) 326 | astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull)) 327 | astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x)) 328 | astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs 329 | astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do 330 | fields' <- traverse toObjectField fields 331 | object <- makeObject fields' 332 | pure (ValueObject' object) 333 | where 334 | toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value 335 | 336 | -- | Convert an AST value to a variable value. 337 | -- 338 | -- Will fail if the AST value contains duplicate object fields, or is 339 | -- otherwise invalid. 340 | astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue 341 | astToVariableValue ast = astToValue' convertScalar ast 342 | where 343 | convertScalar x = 344 | case astToScalar x of 345 | Just scalar -> scalar 346 | Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x) 347 | 348 | -- | Convert a value to an AST value. 349 | valueToAST :: Value -> AST.Value 350 | valueToAST = valueToAST' constScalarToAST 351 | 352 | -- | Convert a variable value to an AST value. 353 | variableValueToAST :: UnresolvedVariableValue -> AST.Value 354 | variableValueToAST = valueToAST' variableToAST 355 | 356 | -- | Convert a literal value into an AST value. 357 | -- 358 | -- Nulls are converted into Nothing. 359 | -- 360 | -- This function probably isn't particularly useful, but it functions as a 361 | -- stop-gap until we have QuickCheck generators for the AST. 362 | valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value 363 | valueToAST' f (ValueScalar' x) = f x 364 | valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs)) 365 | valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields))) 366 | where 367 | toObjectField (name, value) = AST.ObjectField name (valueToAST' f value) 368 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Value/FromValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE AllowAmbiguousTypes #-} 11 | {-# OPTIONS_HADDOCK not-home #-} 12 | 13 | -- | Description: Convert GraphQL values to domain-specific Haskell values 14 | module GraphQL.Internal.Value.FromValue 15 | ( FromValue(..) 16 | , prop_roundtripValue 17 | , wrongType 18 | ) where 19 | 20 | import Protolude hiding (TypeError) 21 | 22 | import qualified Data.List.NonEmpty as NonEmpty 23 | import GHC.Generics ((:*:)(..)) 24 | import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) 25 | import GHC.Types (Type) 26 | 27 | import GraphQL.Internal.Name (nameFromSymbol) 28 | import qualified GraphQL.Internal.OrderedMap as OM 29 | import GraphQL.Internal.Value 30 | import GraphQL.Internal.Value.ToValue (ToValue(..)) 31 | 32 | -- * FromValue 33 | 34 | -- | @a@ can be converted from a GraphQL 'Value' to a Haskell value. 35 | -- 36 | -- The @FromValue@ instance converts 'AST.Value' to the type expected by the 37 | -- handler function. It is the boundary between incoming data and your custom 38 | -- application Haskell types. 39 | -- 40 | -- @FromValue@ has a generic instance for converting input objects to 41 | -- records. 42 | class FromValue a where 43 | -- | Convert an already-parsed value into a Haskell value, generally to be 44 | -- passed to a handler. 45 | fromValue :: Value' ConstScalar -> Either Text a 46 | default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a 47 | fromValue (ValueObject v) = to <$> genericFromValue v 48 | fromValue v = wrongType "genericFromValue only works with objects." v 49 | 50 | instance FromValue Int32 where 51 | fromValue (ValueInt v) = pure v 52 | fromValue v = wrongType "Int" v 53 | 54 | instance FromValue Double where 55 | fromValue (ValueFloat v) = pure v 56 | fromValue v = wrongType "Double" v 57 | 58 | instance FromValue Bool where 59 | fromValue (ValueBoolean v) = pure v 60 | fromValue v = wrongType "Bool" v 61 | 62 | instance FromValue Text where 63 | fromValue (ValueString (String v)) = pure v 64 | fromValue v = wrongType "String" v 65 | 66 | instance forall v. FromValue v => FromValue [v] where 67 | fromValue (ValueList' (List' values)) = traverse (fromValue @v) values 68 | fromValue v = wrongType "List" v 69 | 70 | instance forall v. FromValue v => FromValue (NonEmpty v) where 71 | fromValue (ValueList' (List' values)) = 72 | case NonEmpty.nonEmpty values of 73 | Nothing -> Left "Cannot construct NonEmpty from empty list" 74 | Just values' -> traverse (fromValue @v) values' 75 | fromValue v = wrongType "List" v 76 | 77 | instance forall v. FromValue v => FromValue (Maybe v) where 78 | fromValue ValueNull = pure Nothing 79 | fromValue x = Just <$> fromValue @v x 80 | 81 | -- | Anything that can be converted to a value and from a value should roundtrip. 82 | prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool 83 | prop_roundtripValue x = fromValue (toValue x) == Right x 84 | 85 | -- | Throw an error saying that @value@ does not have the @expected@ type. 86 | wrongType :: (MonadError Text m, Show a) => Text -> a -> m b 87 | wrongType expected value = throwError ("Wrong type, should be: `" <> expected <> "` but is: `" <> show value <> "`") 88 | 89 | -- We only allow generic record reading for now because I am not sure 90 | -- how we should interpret any other generic things (e.g. tuples). 91 | class GenericFromValue (f :: Type -> Type) where 92 | genericFromValue :: Object' ConstScalar -> Either Text (f p) 93 | 94 | instance forall dataName consName records s l p. 95 | ( KnownSymbol dataName 96 | , KnownSymbol consName 97 | , GenericFromValue records 98 | ) => GenericFromValue (D1 ('MetaData dataName s l 'False) 99 | (C1 ('MetaCons consName p 'True) records 100 | )) where 101 | genericFromValue o = M1 . M1 <$> genericFromValue @records o 102 | 103 | 104 | instance forall l r. 105 | ( GenericFromValue l 106 | , GenericFromValue r 107 | ) => GenericFromValue (l :*: r) where 108 | genericFromValue object = liftA2 (:*:) (genericFromValue @l object) (genericFromValue @r object) 109 | 110 | -- | Look up a single record field element in the Object. 111 | getValue :: forall wrappedType fieldName u s l p. (FromValue wrappedType, KnownSymbol fieldName) 112 | => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p) 113 | getValue (Object' fieldMap) = do 114 | fieldName <- case nameFromSymbol @fieldName of 115 | Left err -> throwError ("invalid field name" <> show err) 116 | Right name' -> pure name' 117 | -- TODO(tom): How do we deal with optional fields? Maybe sounds 118 | -- like the correct type, but how would Maybe be different from 119 | -- `null`? Delegating to FromValue not good enough here because of 120 | -- the dictionary lookup. 121 | case OM.lookup fieldName fieldMap of 122 | Nothing -> throwError ("Key not found: " <> show fieldName) 123 | Just v -> M1 . K1 <$> fromValue @wrappedType v 124 | 125 | instance forall wrappedType fieldName u s l. 126 | ( KnownSymbol fieldName 127 | , FromValue wrappedType 128 | ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where 129 | genericFromValue = getValue @wrappedType @fieldName 130 | 131 | instance forall l r m. 132 | ( TypeError ('Text "Generic fromValue only works for records with exactly one data constructor.") 133 | ) => GenericFromValue (D1 m (l :+: r)) where 134 | genericFromValue = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled." 135 | -------------------------------------------------------------------------------- /src/GraphQL/Internal/Value/ToValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | 4 | -- | Description: Turn domain-specific Haskell values into GraphQL values. 5 | module GraphQL.Internal.Value.ToValue 6 | ( ToValue(..) 7 | ) where 8 | 9 | import Protolude 10 | 11 | import GraphQL.Internal.Value 12 | 13 | -- * ToValue 14 | 15 | -- | Turn a Haskell value into a GraphQL value. 16 | class ToValue a where 17 | toValue :: a -> Value' ConstScalar 18 | 19 | instance ToValue (Value' ConstScalar) where 20 | toValue = identity 21 | 22 | -- XXX: Should this just be for Foldable? 23 | instance ToValue a => ToValue [a] where 24 | toValue = toValue . List' . map toValue 25 | 26 | -- TODO - tom still thinks that using Maybe for nullable is maybe not 27 | -- the best idea. 28 | instance ToValue a => ToValue (Maybe a) where 29 | toValue Nothing = ValueNull 30 | toValue (Just v) = toValue v 31 | 32 | instance ToValue a => ToValue (NonEmpty a) where 33 | toValue = toValue . makeList 34 | 35 | instance ToValue Bool where 36 | toValue = ValueBoolean 37 | 38 | instance ToValue Int32 where 39 | toValue = ValueInt 40 | 41 | instance ToValue Double where 42 | toValue = ValueFloat 43 | 44 | instance ToValue String where 45 | toValue = ValueString 46 | 47 | -- XXX: Make more generic: any string-like thing rather than just Text. 48 | instance ToValue Text where 49 | toValue = toValue . String 50 | 51 | instance ToValue List where 52 | toValue = ValueList' 53 | 54 | instance ToValue (Object' ConstScalar) where 55 | toValue = ValueObject' 56 | 57 | 58 | makeList :: (Functor f, Foldable f, ToValue a) => f a -> List 59 | makeList = List' . Protolude.toList . map toValue 60 | -------------------------------------------------------------------------------- /src/GraphQL/Resolver.hs: -------------------------------------------------------------------------------- 1 | -- | Description: Implement handlers for GraphQL schemas 2 | -- 3 | -- Contains everything you need to write handlers for your GraphQL schema. 4 | module GraphQL.Resolver 5 | ( module Export 6 | ) where 7 | 8 | import GraphQL.Internal.Resolver as Export 9 | ( ResolverError(..) 10 | , HasResolver(..) 11 | , OperationResolverConstraint 12 | , (:<>)(..) 13 | , Result(..) 14 | , unionValue 15 | , resolveOperation 16 | , returns 17 | , handlerError 18 | ) 19 | -------------------------------------------------------------------------------- /src/GraphQL/Value.hs: -------------------------------------------------------------------------------- 1 | -- | Description: Literal GraphQL values 2 | {-# LANGUAGE PatternSynonyms #-} 3 | module GraphQL.Value 4 | ( Value 5 | , Value'(..) 6 | , ConstScalar 7 | , UnresolvedVariableValue 8 | , pattern ValueInt 9 | , pattern ValueFloat 10 | , pattern ValueBoolean 11 | , pattern ValueString 12 | , pattern ValueEnum 13 | , pattern ValueList 14 | , pattern ValueObject 15 | , pattern ValueNull 16 | , toObject 17 | , valueToAST 18 | , astToVariableValue 19 | , variableValueToAST 20 | , List 21 | , List'(..) 22 | , String(..) 23 | -- * Names 24 | , Name(..) 25 | , NameError(..) 26 | , makeName 27 | -- * Objects 28 | , Object 29 | , Object'(..) 30 | , ObjectField 31 | , ObjectField'(ObjectField) 32 | -- ** Constructing 33 | , makeObject 34 | , objectFromList 35 | , objectFromOrderedMap 36 | -- ** Combining 37 | , unionObjects 38 | -- ** Querying 39 | , objectFields 40 | -- * Converting to and from Value 41 | , ToValue(..) 42 | , FromValue(..) 43 | ) where 44 | 45 | import GraphQL.Internal.Value 46 | ( Value 47 | , Value'(..) 48 | , ConstScalar 49 | , UnresolvedVariableValue 50 | , pattern ValueInt 51 | , pattern ValueFloat 52 | , pattern ValueBoolean 53 | , pattern ValueString 54 | , pattern ValueEnum 55 | , pattern ValueList 56 | , pattern ValueObject 57 | , pattern ValueNull 58 | , toObject 59 | , valueToAST 60 | , astToVariableValue 61 | , variableValueToAST 62 | , List 63 | , List'(..) 64 | , String(..) 65 | , Name(..) 66 | , NameError(..) 67 | , makeName 68 | , Object 69 | , Object'(..) 70 | , ObjectField 71 | , ObjectField'(ObjectField) 72 | , makeObject 73 | , objectFromList 74 | , objectFromOrderedMap 75 | , unionObjects 76 | , objectFields 77 | ) 78 | import GraphQL.Internal.Value.FromValue 79 | ( FromValue(..) 80 | ) 81 | import GraphQL.Internal.Value.ToValue 82 | ( ToValue(..) 83 | ) 84 | -------------------------------------------------------------------------------- /stack-8.0.yaml: -------------------------------------------------------------------------------- 1 | # GHC 8.0.2 is the lowest supported compiler version. 2 | resolver: lts-9.21 3 | 4 | packages: 5 | - "." 6 | - "./docs/source/tutorial" 7 | - "./graphql-wai" 8 | 9 | extra-deps: 10 | - protolude-0.2.1 11 | -------------------------------------------------------------------------------- /stack-8.2.yaml: -------------------------------------------------------------------------------- 1 | # LTS 10.4 is the latest LTS that supports GHC 8.2 at the time of writing. 2 | resolver: lts-10.4 3 | 4 | packages: 5 | - "." 6 | - "./docs/source/tutorial" 7 | - "./graphql-wai" 8 | -------------------------------------------------------------------------------- /tests/ASTSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | Tests for AST, including parser and encoder. 4 | module ASTSpec (spec) where 5 | 6 | import Protolude 7 | 8 | import Data.Attoparsec.Text (parseOnly) 9 | import Text.RawString.QQ (r) 10 | import Test.Hspec.QuickCheck (prop) 11 | import Test.QuickCheck (arbitrary, forAll, resize) 12 | import Test.Hspec 13 | 14 | import GraphQL.Value (String(..)) 15 | import GraphQL.Internal.Name (Name) 16 | import qualified GraphQL.Internal.Syntax.AST as AST 17 | import qualified GraphQL.Internal.Syntax.Parser as Parser 18 | import qualified GraphQL.Internal.Syntax.Encoder as Encoder 19 | 20 | kitchenSink :: Text 21 | kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n" 22 | 23 | dog :: Name 24 | dog = "dog" 25 | 26 | someName :: Name 27 | someName = "name" 28 | 29 | spec :: Spec 30 | spec = describe "AST" $ do 31 | describe "Parser and encoder" $ do 32 | it "roundtrips on minified documents" $ do 33 | let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink 34 | actual `shouldBe` Right kitchenSink 35 | describe "parsing numbers" $ do 36 | it "works for some integers" $ do 37 | parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1) 38 | prop "works for all integers" $ do 39 | \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x) 40 | it "works for some floats" $ do 41 | parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5) 42 | it "treats floats as floats even if they end with .0" $ do 43 | parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0) 44 | prop "works for floats" $ do 45 | \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x) 46 | describe "strings" $ do 47 | prop "works for all strings" $ do 48 | \(String x) -> 49 | let input = AST.ValueString (AST.StringValue x) 50 | output = Encoder.value input in 51 | parseOnly Parser.value output == Right input 52 | it "handles unusual strings" $ do 53 | let input = AST.ValueString (AST.StringValue "\fh\244") 54 | let output = Encoder.value input 55 | -- \f is \u000c 56 | output `shouldBe` "\"\\u000ch\244\"" 57 | parseOnly Parser.value output `shouldBe` Right input 58 | describe "parsing values" $ do 59 | prop "works for all literal values" $ do 60 | forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x 61 | it "parses ununusual objects" $ do 62 | let input = AST.ValueObject 63 | (AST.ObjectValue 64 | [ AST.ObjectField "s" 65 | (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")), 66 | AST.ObjectField "Hsr" (AST.ValueInt 0) 67 | ]) 68 | let output = Encoder.value input 69 | parseOnly Parser.value output `shouldBe` Right input 70 | it "parses lists of floats" $ do 71 | let input = AST.ValueList 72 | (AST.ListValue 73 | [ AST.ValueFloat 1.5 74 | , AST.ValueFloat 1.5 75 | ]) 76 | let output = Encoder.value input 77 | output `shouldBe` "[1.5,1.5]" 78 | parseOnly Parser.value output `shouldBe` Right input 79 | describe "Parser" $ do 80 | it "parses shorthand syntax documents" $ do 81 | let query = [r|{ 82 | dog { 83 | name 84 | } 85 | }|] 86 | let Right parsed = parseOnly Parser.queryDocument query 87 | let expected = AST.QueryDocument 88 | [ AST.DefinitionOperation 89 | (AST.AnonymousQuery 90 | [ AST.SelectionField 91 | (AST.Field Nothing dog [] [] 92 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 93 | ]) 94 | ]) 95 | ] 96 | parsed `shouldBe` expected 97 | 98 | it "parses anonymous query documents" $ do 99 | let query = [r|query { 100 | dog { 101 | name 102 | } 103 | }|] 104 | let Right parsed = parseOnly Parser.queryDocument query 105 | let expected = AST.QueryDocument 106 | [ AST.DefinitionOperation 107 | (AST.Query 108 | (AST.Node Nothing [] [] 109 | [ AST.SelectionField 110 | (AST.Field Nothing dog [] [] 111 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 112 | ]) 113 | ])) 114 | ] 115 | parsed `shouldBe` expected 116 | 117 | it "errors on missing selection set" $ do 118 | let query = [r|query { 119 | dog { 120 | 121 | } 122 | }|] 123 | let Left parsed = parseOnly Parser.queryDocument query 124 | -- this is not very explicit 125 | parsed `shouldBe` "query document error! > definition error!: string" 126 | 127 | it "parses invalid documents" $ do 128 | let query = [r|{ 129 | dog { 130 | name 131 | } 132 | } 133 | 134 | query getName { 135 | dog { 136 | owner { 137 | name 138 | } 139 | } 140 | }|] 141 | let Right parsed = parseOnly Parser.queryDocument query 142 | let expected = AST.QueryDocument 143 | [ AST.DefinitionOperation 144 | (AST.AnonymousQuery 145 | [ AST.SelectionField 146 | (AST.Field Nothing dog [] [] 147 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 148 | ]) 149 | ]) 150 | , AST.DefinitionOperation 151 | (AST.Query 152 | (AST.Node (pure "getName") [] [] 153 | [ AST.SelectionField 154 | (AST.Field Nothing dog [] [] 155 | [ AST.SelectionField 156 | (AST.Field Nothing "owner" [] [] 157 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 158 | ]) 159 | ]) 160 | ])) 161 | ] 162 | parsed `shouldBe` expected 163 | 164 | it "includes variable definitions" $ do 165 | let query = [r| 166 | query houseTrainedQuery($atOtherHomes: Boolean = true) { 167 | dog { 168 | isHousetrained(atOtherHomes: $atOtherHomes) 169 | } 170 | } 171 | |] 172 | let Right parsed = parseOnly Parser.queryDocument query 173 | let expected = AST.QueryDocument 174 | [ AST.DefinitionOperation 175 | (AST.Query 176 | (AST.Node (pure "houseTrainedQuery") 177 | [ AST.VariableDefinition 178 | (AST.Variable "atOtherHomes") 179 | (AST.TypeNamed (AST.NamedType "Boolean")) 180 | (Just (AST.ValueBoolean True)) 181 | ] [] 182 | [ AST.SelectionField 183 | (AST.Field Nothing dog [] [] 184 | [ AST.SelectionField 185 | (AST.Field Nothing "isHousetrained" 186 | [ AST.Argument "atOtherHomes" 187 | (AST.ValueVariable (AST.Variable "atOtherHomes")) 188 | ] [] []) 189 | ]) 190 | ])) 191 | ] 192 | parsed `shouldBe` expected 193 | 194 | it "parses anonymous query with variables" $ do 195 | let query = [r| 196 | query ($atOtherHomes: Boolean = true) { 197 | dog { 198 | isHousetrained(atOtherHomes: $atOtherHomes) 199 | } 200 | } 201 | |] 202 | let Right parsed = parseOnly Parser.queryDocument query 203 | let expected = AST.QueryDocument 204 | [ AST.DefinitionOperation 205 | (AST.Query 206 | (AST.Node Nothing 207 | [ AST.VariableDefinition 208 | (AST.Variable "atOtherHomes") 209 | (AST.TypeNamed (AST.NamedType "Boolean")) 210 | (Just (AST.ValueBoolean True)) 211 | ] [] 212 | [ AST.SelectionField 213 | (AST.Field Nothing dog [] [] 214 | [ AST.SelectionField 215 | (AST.Field Nothing "isHousetrained" 216 | [ AST.Argument "atOtherHomes" 217 | (AST.ValueVariable (AST.Variable "atOtherHomes")) 218 | ] [] []) 219 | ]) 220 | ])) 221 | ] 222 | parsed `shouldBe` expected 223 | it "parses anonymous query with variable annotation" $ do 224 | let query = [r| 225 | query ($atOtherHomes: [Home!]) { 226 | dog { 227 | isHousetrained(atOtherHomes: $atOtherHomes) 228 | } 229 | } 230 | |] 231 | let Right parsed = parseOnly Parser.queryDocument query 232 | let expected = AST.QueryDocument 233 | [ AST.DefinitionOperation 234 | (AST.Query 235 | (AST.Node Nothing 236 | [ AST.VariableDefinition 237 | (AST.Variable "atOtherHomes") 238 | (AST.TypeList 239 | (AST.ListType 240 | (AST.TypeNonNull 241 | (AST.NonNullTypeNamed (AST.NamedType "Home")) 242 | ) 243 | ) 244 | ) 245 | Nothing 246 | ] [] 247 | [ AST.SelectionField 248 | (AST.Field Nothing dog [] [] 249 | [ AST.SelectionField 250 | (AST.Field Nothing "isHousetrained" 251 | [ AST.Argument "atOtherHomes" 252 | (AST.ValueVariable (AST.Variable "atOtherHomes")) 253 | ] [] []) 254 | ]) 255 | ])) 256 | ] 257 | parsed `shouldBe` expected 258 | it "parses anonymous query with inline argument (List, Object, Enum, String, Number)" $ do 259 | -- keys are not quoted for inline objects 260 | let query = [r| 261 | query { 262 | dog { 263 | isHousetrained(atOtherHomes: [{testKey: 123, anotherKey: "string"}]) 264 | } 265 | } 266 | |] 267 | let Right parsed = parseOnly Parser.queryDocument query 268 | let expected = AST.QueryDocument 269 | [ AST.DefinitionOperation 270 | (AST.Query 271 | (AST.Node Nothing 272 | [] [] 273 | [ AST.SelectionField 274 | (AST.Field Nothing dog [] [] 275 | [ AST.SelectionField 276 | (AST.Field Nothing "isHousetrained" 277 | [ AST.Argument "atOtherHomes" 278 | (AST.ValueList (AST.ListValue [ 279 | (AST.ValueObject (AST.ObjectValue [ 280 | (AST.ObjectField "testKey" (AST.ValueInt 123)), 281 | (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) 282 | ])) 283 | ])) 284 | ] [] []) 285 | ]) 286 | ])) 287 | ] 288 | parsed `shouldBe` expected 289 | it "parses anonymous query with fragment" $ do 290 | -- keys are not quoted for inline objects 291 | let query = [r| 292 | fragment dogTest on Dog { 293 | name 294 | } 295 | query { 296 | dog { 297 | ...dogTest 298 | } 299 | } 300 | |] 301 | let Right parsed = parseOnly Parser.queryDocument query 302 | let expected = AST.QueryDocument 303 | [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" 304 | (AST.NamedType "Dog") [] [ 305 | AST.SelectionField (AST.Field Nothing "name" [] [] []) 306 | ])), 307 | (AST.DefinitionOperation 308 | (AST.Query 309 | (AST.Node Nothing 310 | [] [] 311 | [AST.SelectionField 312 | (AST.Field Nothing dog [] [] 313 | [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) 314 | ]) 315 | ]))) 316 | ] 317 | parsed `shouldBe` expected 318 | -------------------------------------------------------------------------------- /tests/EnumTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module EnumTests ( Mode(Directory, NormalFile, ExecutableFile, Symlink) ) where 3 | 4 | import Protolude hiding (Enum) 5 | 6 | import GraphQL.API (GraphQLEnum) 7 | 8 | -- https://github.com/jml/graphql-api/issues/116 9 | -- Generic enum code is broken 10 | 11 | data Mode = Directory | NormalFile | ExecutableFile | Symlink deriving (Show, Eq, Generic) 12 | 13 | instance GraphQLEnum Mode 14 | -------------------------------------------------------------------------------- /tests/ExampleSchema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | -- | An example GraphQL schema, used in our end-to-end tests. 8 | -- 9 | -- Based on the example schema given in the GraphQL spec. See 10 | -- . 11 | -- 12 | -- Here's the full schema: 13 | -- 14 | -- @ 15 | -- enum DogCommand { SIT, DOWN, HEEL } 16 | -- 17 | -- type Dog implements Pet { 18 | -- name: String! 19 | -- nickname: String 20 | -- barkVolume: Int 21 | -- doesKnowCommand(dogCommand: DogCommand!): Boolean! 22 | -- isHousetrained(atOtherHomes: Boolean): Boolean! 23 | -- owner: Human 24 | -- } 25 | -- 26 | -- interface Sentient { 27 | -- name: String! 28 | -- } 29 | -- 30 | -- interface Pet { 31 | -- name: String! 32 | -- } 33 | -- 34 | -- type Alien implements Sentient { 35 | -- name: String! 36 | -- homePlanet: String 37 | -- } 38 | -- 39 | -- type Human implements Sentient { 40 | -- name: String! 41 | -- } 42 | -- 43 | -- enum CatCommand { JUMP } 44 | -- 45 | -- type Cat implements Pet { 46 | -- name: String! 47 | -- nickname: String 48 | -- doesKnowCommand(catCommand: CatCommand!): Boolean! 49 | -- meowVolume: Int 50 | -- } 51 | -- 52 | -- union CatOrDog = Cat | Dog 53 | -- union DogOrHuman = Dog | Human 54 | -- union HumanOrAlien = Human | Alien 55 | -- @ 56 | -- 57 | -- Unlike the spec, we don't define a @QueryRoot@ type here, instead 58 | -- encouraging test modules to define their own as appropriate to their needs. 59 | -- 60 | -- We'll repeat bits of the schema below, explaining how they translate into 61 | -- Haskell as we go. 62 | 63 | module ExampleSchema 64 | ( DogCommand(..) 65 | , Dog 66 | , Sentient 67 | , Pet 68 | , Alien 69 | , Human 70 | , CatCommand(..) 71 | , Cat 72 | , CatOrDog 73 | , DogOrHuman 74 | , HumanOrAlien 75 | ) where 76 | 77 | import Protolude hiding (Enum) 78 | 79 | import GraphQL.API 80 | ( GraphQLEnum(..) 81 | , Enum 82 | , Object 83 | , Field 84 | , Argument 85 | , Interface 86 | , Union 87 | , (:>) 88 | , Defaultable(..) 89 | ) 90 | import GraphQL.Value 91 | ( pattern ValueEnum 92 | , unName 93 | , ToValue(..) 94 | ) 95 | 96 | -- | A command that can be given to a 'Dog'. 97 | -- 98 | -- @ 99 | -- enum DogCommand { SIT, DOWN, HEEL } 100 | -- @ 101 | -- 102 | -- To define this in Haskell we need to do three things: 103 | -- 104 | -- 1. Define a sum type with nullary constructors to represent the enum 105 | -- (here, 'DogCommandEnum') 106 | -- 2. Make it an instance of 'GraphQLEnum' 107 | -- 3. Wrap the sum type in 'Enum', e.g. @Enum "DogCommand" DogCommandEnum@ 108 | -- so it can be placed in a schema. 109 | data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic) 110 | 111 | instance Defaultable DogCommand where 112 | -- Explicitly want no default for dogCommand 113 | defaultFor (unName -> "dogCommand") = Nothing 114 | -- DogCommand shouldn't be used elsewhere in schema, but who can say? 115 | defaultFor _ = Nothing 116 | 117 | instance GraphQLEnum DogCommand 118 | 119 | -- TODO: Probably shouldn't have to do this for enums. 120 | instance ToValue DogCommand where 121 | toValue = ValueEnum . enumToValue 122 | 123 | -- | A dog. 124 | -- 125 | -- This is an example of a GraphQL \"object\". 126 | -- 127 | -- @ 128 | -- type Dog implements Pet { 129 | -- name: String! 130 | -- nickname: String 131 | -- barkVolume: Int 132 | -- doesKnowCommand(dogCommand: DogCommand!): Boolean! 133 | -- isHousetrained(atOtherHomes: Boolean): Boolean! 134 | -- owner: Human 135 | -- } 136 | -- @ 137 | -- 138 | -- To define it in Haskell, we use 'Object'. The first argument is the name of 139 | -- the object (here, @"Dog"@). The second is a list of interfaces implemented 140 | -- by the object (here, only 'Pet'). 141 | -- 142 | -- The third, final, and most interesting argument is the list of fields the 143 | -- object has. Fields can look one of two ways: 144 | -- 145 | -- @ 146 | -- Field "name" Text 147 | -- @ 148 | -- 149 | -- for a field that takes no arguments. This field would be called @name@ and 150 | -- is guaranteed to return some text if queried. 151 | -- 152 | -- A field that takes arguments looks like this: 153 | -- 154 | -- @ 155 | -- Argument "dogCommand" DogCommand :> Field "doesKnowCommand" Bool 156 | -- @ 157 | -- 158 | -- Here, the field is named @doesKnowCommand@ and it takes a single 159 | -- argument--a 'DogCommand'--and returns a 'Bool'. Note that this is in 160 | -- reverse order to the GraphQL schema, which represents this field as: 161 | -- 162 | -- @ 163 | -- doesKnowCommand(dogCommand: DogCommand!): Boolean! 164 | -- @ 165 | -- 166 | -- Also note that all fields and arguments are "non-null" by default. If you 167 | -- want a field to be nullable, give it a 'Maybe' type, e.g. 168 | -- 169 | -- @ 170 | -- nickname: String 171 | -- @ 172 | -- 173 | -- @nickname@ is nullable, so we represent the field in Haskell as: 174 | -- 175 | -- @ 176 | -- Field "nickname" (Maybe Text) 177 | -- @ 178 | type Dog = Object "Dog" '[Pet] 179 | '[ Field "name" Text 180 | , Field "nickname" (Maybe Text) 181 | , Field "barkVolume" Int32 182 | , Argument "dogCommand" (Enum "DogCommand" DogCommand) :> Field "doesKnowCommand" Bool 183 | , Argument "atOtherHomes" (Maybe Bool) :> Field "isHouseTrained" Bool 184 | , Field "owner" Human 185 | ] 186 | 187 | -- | Sentient beings have names. 188 | -- 189 | -- This defines an interface, 'Sentient', that objects can implement. 190 | -- 191 | -- @ 192 | -- interface Sentient { 193 | -- name: String! 194 | -- } 195 | -- @ 196 | type Sentient = Interface "Sentient" '[Field "name" Text] 197 | 198 | -- | Pets have names too. 199 | -- 200 | -- This defines an interface, 'Pet', that objects can implement. 201 | -- 202 | -- @ 203 | -- interface Pet { 204 | -- name: String! 205 | -- } 206 | -- @ 207 | type Pet = Interface "Pet" '[Field "name" Text] 208 | 209 | -- | An alien. 210 | -- 211 | -- See 'Dog' for more details on how to define an object type for GraphQL. 212 | -- 213 | -- @ 214 | -- type Alien implements Sentient { 215 | -- name: String! 216 | -- homePlanet: String 217 | -- } 218 | -- @ 219 | type Alien = Object "Alien" '[Sentient] 220 | '[ Field "name" Text 221 | , Field "homePlanet" (Maybe Text) 222 | ] 223 | 224 | -- | Humans are sentient. 225 | -- 226 | -- See 'Dog' for more details on how to define an object type for GraphQL. 227 | -- 228 | -- @ 229 | -- type Human implements Sentient { 230 | -- name: String! 231 | -- } 232 | -- @ 233 | type Human = Object "Human" '[Sentient] 234 | '[ Field "name" Text 235 | ] 236 | 237 | -- TODO: Extend example to cover unions, interfaces and lists by giving humans 238 | -- a list of pets and a list of cats & dogs. 239 | 240 | -- | Cats can jump. 241 | -- 242 | -- See 'DogCommandEnum' for more details on defining an enum for GraphQL. 243 | -- 244 | -- The interesting thing about 'CatCommandEnum' is that it's an enum that has 245 | -- only one possible value. 246 | -- 247 | -- @ 248 | -- enum CatCommand { JUMP } 249 | -- @ 250 | data CatCommand = Jump deriving Generic 251 | 252 | instance Defaultable CatCommand where 253 | defaultFor _ = empty 254 | 255 | instance GraphQLEnum CatCommand 256 | 257 | -- | A cat. 258 | -- 259 | -- See 'Dog' for more details on how to define an object type for GraphQL. 260 | -- 261 | -- @ 262 | -- type Cat implements Pet { 263 | -- name: String! 264 | -- nickname: String 265 | -- doesKnowCommand(catCommand: CatCommand!): Boolean! 266 | -- meowVolume: Int 267 | -- } 268 | -- @ 269 | type Cat = Object "Cat" '[Pet] 270 | '[ Field "name" Text 271 | , Field "nickName" (Maybe Text) 272 | , Argument "catCommand" (Enum "CatCommand" CatCommand) :> Field "doesKnowCommand" Bool 273 | , Field "meowVolume" Int32 274 | ] 275 | 276 | -- | Either a cat or a dog. (Pick dog, dogs are awesome). 277 | -- 278 | -- A 'Union' is used when you want to return one of short list of known 279 | -- types. 280 | -- 281 | -- You define them in GraphQL like so: 282 | -- 283 | -- @ 284 | -- union CatOrDog = Cat | Dog 285 | -- @ 286 | -- 287 | -- To translate this to Haskell, define a new type using 'Union'. The first 288 | -- argument is the name of the union, here @"CatOrDog"@, and the second 289 | -- argument is the list of possible types of the union. These must be objects, 290 | -- defined with 'Object'. 291 | type CatOrDog = Union "CatOrDog" '[Cat, Dog] 292 | 293 | -- | Either a dog or a human. (Pick dog, dogs are awesome). 294 | -- 295 | -- See 'CatOrDog' for more details on defining a union. 296 | -- 297 | -- @ 298 | -- union DogOrHuman = Dog | Human 299 | -- @ 300 | type DogOrHuman = Union "DogOrHuman" '[Dog, Human] 301 | 302 | -- | Either a human or an alien. (Pick dog, dogs are awesome). 303 | -- 304 | -- See 'CatOrDog' for more details on defining a union. 305 | -- 306 | -- @ 307 | -- union HumanOrAlien = Human | Alien 308 | -- @ 309 | type HumanOrAlien = Union "HumanOrAlien" '[Human, Alien] 310 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Protolude 4 | 5 | import Test.Hspec 6 | import qualified Spec (spec) 7 | 8 | main :: IO () 9 | main = do 10 | hspec Spec.spec 11 | -------------------------------------------------------------------------------- /tests/OrderedMapSpec.hs: -------------------------------------------------------------------------------- 1 | module OrderedMapSpec (spec) where 2 | 3 | import Protolude 4 | 5 | import Test.Hspec.QuickCheck (prop) 6 | import Test.QuickCheck (Gen, arbitrary, forAll) 7 | import Test.Hspec 8 | 9 | import qualified Data.Map as Map 10 | import GraphQL.Internal.OrderedMap (OrderedMap) 11 | import qualified GraphQL.Internal.OrderedMap as OrderedMap 12 | 13 | 14 | orderedMaps :: Gen (OrderedMap Int Int) 15 | orderedMaps = arbitrary 16 | 17 | spec :: Spec 18 | spec = describe "OrderedMap" $ do 19 | describe "Integrity" $ do 20 | prop "fromList . toList == id" $ do 21 | forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x) 22 | prop "keys == Map.keys . toMap" $ do 23 | forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x))) 24 | prop "keys == map fst . Map.toList" $ do 25 | forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x)) 26 | prop "has unique keys" $ do 27 | forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks) 28 | prop "all keys can be looked up" $ do 29 | forAll orderedMaps (\x -> let keys = OrderedMap.keys x 30 | values = OrderedMap.values x 31 | in mapMaybe (flip OrderedMap.lookup x) keys == values) 32 | it "empty is orderedMap []" $ do 33 | Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap [] 34 | prop "singleton x is orderedMap [x]" $ do 35 | \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)] 36 | it "preserves insertion order" $ do 37 | let items1 = [("foo", 2), ("bar", 1)] 38 | let Just x = OrderedMap.orderedMap items1 39 | OrderedMap.toList @Text @Int x `shouldBe` items1 40 | let items2 = [("bar", 1), ("foo", 2)] 41 | let Just y = OrderedMap.orderedMap items2 42 | OrderedMap.toList @Text @Int y `shouldBe` items2 43 | -------------------------------------------------------------------------------- /tests/ResolverSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | module ResolverSpec (spec) where 5 | 6 | import Protolude hiding (Enum) 7 | 8 | import Test.Hspec 9 | 10 | import Data.Aeson (encode, toJSON, object, (.=), Value(Null)) 11 | import GraphQL 12 | ( Response(..) 13 | , interpretAnonymousQuery 14 | ) 15 | import GraphQL.API 16 | ( Object 17 | , Field 18 | , Argument 19 | , Enum 20 | , List 21 | , (:>) 22 | ) 23 | import GraphQL.Resolver 24 | ( Handler 25 | , ResolverError(..) 26 | , (:<>)(..) 27 | , returns 28 | , handlerError 29 | ) 30 | import GraphQL.Internal.Output (singleError) 31 | import qualified GraphQL.Value as GValue 32 | import EnumTests ( Mode(NormalFile) ) 33 | 34 | -- Test a custom error monad 35 | type TMonad = ExceptT Text IO 36 | type T = Object "T" '[] '[ Field "z" Int32 37 | , Argument "x" Int32 :> Field "t" Int32 38 | , Argument "y" Int32 :> Field "q" (Maybe Int32) 39 | , Argument "d" Double :> Field "r" Double 40 | , Field "l" (List Int32) 41 | , Argument "n" Text :> Field "foo" (Maybe Foo) 42 | , Field "bar" (Maybe Foo) 43 | ] 44 | 45 | tHandler :: Handler TMonad T 46 | tHandler = pure $ 47 | returns 10 48 | :<> (\x -> if x == 99 then handlerError "missed 99th value" else returns x) 49 | :<> returns . Just . (returns . (*2)) 50 | :<> (\dArg -> if dArg == 9.9 then handlerError "bad 9.9 value" else returns dArg) 51 | :<> returns ([ returns 0, returns 7, handlerError "no number 9" ]) 52 | :<> (\_nArg -> returns $ Just $ return $ returns "fred") 53 | :<> returns Nothing 54 | 55 | -- https://github.com/jml/graphql-api/issues/119 56 | -- Maybe X didn't descend into its argument. Now it does. 57 | type Query = Object "Query" '[] 58 | '[ Argument "id" Text :> Field "test" (Maybe Foo) ] 59 | 60 | type Foo = Object "Foo" '[] 61 | '[ Field "name" Text ] 62 | 63 | data ServerFoo = ServerFoo 64 | { name :: Text 65 | } deriving (Eq, Show) 66 | 67 | lookupFoo :: Text -> IO (Maybe ServerFoo) 68 | lookupFoo _ = pure $ Just (ServerFoo "Mort") 69 | 70 | viewFoo :: ServerFoo -> Handler IO Foo 71 | viewFoo ServerFoo { name=name } = pure $ returns $ name 72 | 73 | handler :: Handler IO Query 74 | handler = pure $ \fooId -> do 75 | foo <- lookupFoo fooId 76 | returns $ viewFoo <$> foo 77 | 78 | -- Enum test 79 | type EnumQuery = Object "File" '[] 80 | '[ Field "mode" (Enum "modeEnumName" Mode) ] 81 | 82 | enumHandler :: Handler IO EnumQuery 83 | enumHandler = pure $ returns NormalFile 84 | 85 | enumHandler2 :: Handler IO EnumQuery 86 | enumHandler2 = pure $ handlerError "I forgot!" 87 | 88 | -- /Enum test 89 | 90 | spec :: Spec 91 | spec = describe "TypeAPI" $ do 92 | describe "tTest" $ do 93 | it "works in a simple Int32 case" $ do 94 | Right (Success obj) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") 95 | encode obj `shouldBe` "{\"t\":12}" 96 | it "works in a simple Double case" $ do 97 | r <- runExceptT (interpretAnonymousQuery @T tHandler "{ r(d: 1.2) }") 98 | case r of 99 | Right (Success obj) -> encode obj `shouldBe` "{\"r\":1.2}" 100 | _ -> r `shouldNotBe` r 101 | it "works for value and error list elements" $ do 102 | r <- runExceptT (interpretAnonymousQuery @T tHandler "{ l }") 103 | case r of 104 | Right (PartialSuccess obj err) -> do 105 | encode obj `shouldBe` "{\"l\":[0,7,null]}" 106 | err `shouldBe` (singleError (HandlerError "no number 9")) 107 | _ -> r `shouldNotBe` r 108 | it "works for Nullable present elements" $ do 109 | r <- runExceptT (interpretAnonymousQuery @T tHandler "{ foo(n: \"flintstone\") { name } }") 110 | case r of 111 | Right (Success obj) -> do 112 | encode obj `shouldBe` "{\"foo\":{\"name\":\"fred\"}}" 113 | _ -> r `shouldNotBe` r 114 | it "works for Nullable null elements" $ do 115 | r <- runExceptT (interpretAnonymousQuery @T tHandler "{ bar { name } }") 116 | case r of 117 | Right (Success obj) -> do 118 | encode obj `shouldBe` "{\"bar\":null}" 119 | _ -> r `shouldNotBe` r 120 | it "complains about a missing field" $ do 121 | Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") 122 | errs `shouldBe` singleError (FieldNotFoundError "not_a_field") 123 | it "complains about a handler throwing an exception" $ do 124 | r <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 99) }") 125 | case r of 126 | Right (PartialSuccess v errs) -> do 127 | -- n.b. this hasn't gone through the final JSON embedding, 128 | -- so it's the individual components instead of the final 129 | -- response of '{ "data": ..., "errors": ... }' 130 | errs `shouldBe` (singleError (HandlerError "missed 99th value")) 131 | toJSON (GValue.toValue v) `shouldBe` object [ "t" .= Null ] 132 | _ -> r `shouldNotBe` r 133 | it "complains about missing argument" $ do 134 | Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") 135 | errs `shouldBe` singleError (ValueMissing "x") 136 | describe "issue 119" $ do 137 | it "Just works" $ do 138 | Success obj <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }" 139 | encode obj `shouldBe` "{\"test\":{\"name\":\"Mort\"}}" 140 | describe "Parse, validate and execute queries against API" $ do 141 | it "API.Enum works" $ do 142 | Success obj <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" 143 | encode obj `shouldBe` "{\"mode\":\"NormalFile\"}" 144 | it "API.Enum handles errors" $ do 145 | r <- interpretAnonymousQuery @EnumQuery enumHandler2 "{ mode }" 146 | case r of 147 | (PartialSuccess obj errs) -> do 148 | encode obj `shouldBe` "{\"mode\":null}" 149 | errs `shouldBe` (singleError $ HandlerError "I forgot!") 150 | _ -> r `shouldNotBe` r 151 | -------------------------------------------------------------------------------- /tests/SchemaSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module SchemaSpec (spec) where 4 | 5 | import Protolude hiding (Down, Enum) 6 | 7 | import Test.Hspec 8 | 9 | import GraphQL.API 10 | ( Field 11 | , Enum 12 | , List 13 | , getAnnotatedInputType 14 | , getDefinition 15 | ) 16 | import qualified GraphQL.Internal.Syntax.AST as AST 17 | import GraphQL.Internal.API 18 | ( getAnnotatedType 19 | , getFieldDefinition 20 | , getInterfaceDefinition 21 | ) 22 | import GraphQL.Internal.Schema 23 | ( EnumTypeDefinition(..) 24 | , EnumValueDefinition(..) 25 | , FieldDefinition(..) 26 | , ObjectTypeDefinition(..) 27 | , InterfaceTypeDefinition(..) 28 | , AnnotatedType(..) 29 | , ListType(..) 30 | , UnionTypeDefinition(..) 31 | , GType(..) 32 | , TypeDefinition(..) 33 | , InputTypeDefinition(..) 34 | , InputObjectTypeDefinition(..) 35 | , InputObjectFieldDefinition(..) 36 | , ScalarTypeDefinition(..) 37 | , AnnotatedType(..) 38 | , NonNullType(..) 39 | , Builtin(..) 40 | , InputType(..) 41 | , getInputTypeDefinition 42 | , builtinFromName 43 | , astAnnotationToSchemaAnnotation 44 | ) 45 | import ExampleSchema 46 | 47 | spec :: Spec 48 | spec = describe "Type" $ do 49 | describe "Field" $ 50 | it "encodes correctly" $ do 51 | getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) 52 | describe "Interface" $ 53 | it "encodes correctly" $ do 54 | getInterfaceDefinition @Sentient `shouldBe` 55 | Right (InterfaceTypeDefinition 56 | "Sentient" 57 | (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])) 58 | describe "full example" $ 59 | it "encodes correctly" $ do 60 | getDefinition @Human `shouldBe` 61 | Right (ObjectTypeDefinition "Human" 62 | [ InterfaceTypeDefinition "Sentient" ( 63 | FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []) 64 | ] 65 | (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])) 66 | describe "output Enum" $ 67 | it "encodes correctly" $ do 68 | getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe` 69 | Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" 70 | [ EnumValueDefinition "Sit" 71 | , EnumValueDefinition "Down" 72 | , EnumValueDefinition "Heel" 73 | ]))))) 74 | describe "Union type" $ 75 | it "encodes correctly" $ do 76 | getAnnotatedType @CatOrDog `shouldBe` 77 | TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog" 78 | <$> sequence (getDefinition @Cat :| [getDefinition @Dog]) 79 | describe "List" $ 80 | it "encodes correctly" $ do 81 | getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))) 82 | getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt))))) 83 | describe "TypeDefinition accepted as InputTypes" $ 84 | it "Enum/InputObject/Scalar" $ do 85 | getInputTypeDefinition (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" 86 | [ EnumValueDefinition "Sit" 87 | , EnumValueDefinition "Down" 88 | , EnumValueDefinition "Heel" 89 | ])) `shouldBe` Just (InputTypeDefinitionEnum (EnumTypeDefinition "DogCommand" 90 | [ EnumValueDefinition "Sit" 91 | , EnumValueDefinition "Down" 92 | , EnumValueDefinition "Heel" 93 | ])) 94 | getInputTypeDefinition (TypeDefinitionInputObject (InputObjectTypeDefinition "Human" 95 | (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) 96 | )) `shouldBe` Just (InputTypeDefinitionObject (InputObjectTypeDefinition "Human" 97 | (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) 98 | )) 99 | getInputTypeDefinition (TypeDefinitionScalar (ScalarTypeDefinition "Human")) `shouldBe` Just (InputTypeDefinitionScalar (ScalarTypeDefinition "Human")) 100 | describe "TypeDefinition refused as InputTypes" $ 101 | -- todo: add all the others (union type, ..?) 102 | it "Object" $ do 103 | getInputTypeDefinition (TypeDefinitionObject (ObjectTypeDefinition "Human" [] 104 | (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))) `shouldBe` Nothing 105 | describe "Builtin types from name" $ 106 | it "Int/Bool/String/Float/ID" $ do 107 | builtinFromName "Int" `shouldBe` Just GInt 108 | builtinFromName "Boolean" `shouldBe` Just GBool 109 | builtinFromName "String" `shouldBe` Just GString 110 | builtinFromName "Float" `shouldBe` Just GFloat 111 | builtinFromName "ID" `shouldBe` Just GID 112 | builtinFromName "RANDOMSTRING" `shouldBe` Nothing 113 | describe "Annotations from AST" $ 114 | it "annotation like [[ScalarType!]]!" $ do 115 | let typeDefinitionScalar = (TypeDefinitionScalar (ScalarTypeDefinition "ScalarType")) 116 | astAnnotationToSchemaAnnotation ( 117 | AST.TypeNonNull ( 118 | AST.NonNullTypeList ( 119 | AST.ListType ( 120 | AST.TypeList ( 121 | AST.ListType ( 122 | AST.TypeNonNull ( 123 | AST.NonNullTypeNamed (AST.NamedType "ScalarType") 124 | ))))))) typeDefinitionScalar `shouldBe` ( 125 | TypeNonNull ( 126 | NonNullTypeList ( 127 | ListType ( 128 | TypeList ( 129 | ListType ( 130 | TypeNonNull ( 131 | NonNullTypeNamed typeDefinitionScalar 132 | ))))))) 133 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} 2 | -------------------------------------------------------------------------------- /tests/ValidationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE DataKinds #-} 3 | 4 | -- | Tests for query validation. 5 | module ValidationSpec (spec) where 6 | 7 | import Protolude 8 | 9 | import Test.Hspec.QuickCheck (prop) 10 | import Test.QuickCheck ((===)) 11 | import Test.Hspec 12 | import qualified Data.Set as Set 13 | 14 | import GraphQL.Internal.Name (Name) 15 | import qualified GraphQL.Internal.Syntax.AST as AST 16 | import GraphQL.Internal.Schema (emptySchema, Schema) 17 | import GraphQL.Internal.Validation 18 | ( ValidationError(..) 19 | , findDuplicates 20 | , getErrors 21 | , formatErrors 22 | ) 23 | 24 | me :: Maybe Name 25 | me = pure "me" 26 | 27 | someName :: Name 28 | someName = "name" 29 | 30 | dog :: Name 31 | dog = "dog" 32 | 33 | -- | Schema used for these tests. Since none of them do type-level stuff, we 34 | -- don't need to define it. 35 | schema :: Schema 36 | schema = emptySchema 37 | 38 | spec :: Spec 39 | spec = describe "Validation" $ do 40 | describe "getErrors" $ do 41 | it "Treats simple queries as valid" $ do 42 | let doc = AST.QueryDocument 43 | [ AST.DefinitionOperation 44 | ( AST.Query 45 | ( AST.Node me [] [] 46 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 47 | ] 48 | ) 49 | ) 50 | ] 51 | getErrors schema doc `shouldBe` [] 52 | 53 | it "Treats anonymous queries as valid" $ do 54 | let doc = AST.QueryDocument 55 | [ AST.DefinitionOperation 56 | (AST.Query 57 | (AST.Node Nothing [] [] 58 | [ AST.SelectionField 59 | (AST.Field Nothing dog [] [] 60 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 61 | ]) 62 | ])) 63 | ] 64 | getErrors schema doc `shouldBe` [] 65 | 66 | it "Treats anonymous queries with variables as valid" $ do 67 | let doc = AST.QueryDocument 68 | [ AST.DefinitionOperation 69 | (AST.Query 70 | (AST.Node Nothing 71 | [ AST.VariableDefinition 72 | (AST.Variable "atOtherHomes") 73 | (AST.TypeNamed (AST.NamedType "Boolean")) 74 | (Just (AST.ValueBoolean True)) 75 | ] [] 76 | [ AST.SelectionField 77 | (AST.Field Nothing dog [] [] 78 | [ AST.SelectionField 79 | (AST.Field Nothing "isHousetrained" 80 | [ AST.Argument "atOtherHomes" 81 | (AST.ValueVariable (AST.Variable "atOtherHomes")) 82 | ] [] []) 83 | ]) 84 | ])) 85 | ] 86 | getErrors schema doc `shouldBe` [] 87 | it "Treats anonymous queries with annotated variables as valid ([[Boolean]]!)" $ do 88 | let doc = AST.QueryDocument 89 | [ AST.DefinitionOperation 90 | (AST.Query 91 | (AST.Node Nothing 92 | [ AST.VariableDefinition 93 | (AST.Variable "atOtherHomes") 94 | (AST.TypeNonNull (AST.NonNullTypeList (AST.ListType 95 | (AST.TypeList (AST.ListType (AST.TypeNamed (AST.NamedType "Boolean")))) 96 | ))) 97 | Nothing 98 | ] [] 99 | [ AST.SelectionField 100 | (AST.Field Nothing dog [] [] 101 | [ AST.SelectionField 102 | (AST.Field Nothing "isHousetrained" 103 | [ AST.Argument "atOtherHomes" 104 | (AST.ValueVariable (AST.Variable "atOtherHomes")) 105 | ] [] []) 106 | ]) 107 | ])) 108 | ] 109 | getErrors schema doc `shouldBe` [] 110 | 111 | it "Detects duplicate operation names" $ do 112 | let doc = AST.QueryDocument 113 | [ AST.DefinitionOperation 114 | ( AST.Query 115 | ( AST.Node me [] [] 116 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 117 | ] 118 | ) 119 | ) 120 | , AST.DefinitionOperation 121 | ( AST.Query 122 | ( AST.Node me [] [] 123 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 124 | ] 125 | ) 126 | ) 127 | ] 128 | getErrors schema doc `shouldBe` [DuplicateOperation me] 129 | 130 | it "Detects duplicate anonymous operations" $ do 131 | let doc = AST.QueryDocument 132 | [ AST.DefinitionOperation 133 | ( AST.AnonymousQuery 134 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 135 | ] 136 | ) 137 | , AST.DefinitionOperation 138 | ( AST.AnonymousQuery 139 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 140 | ] 141 | ) 142 | ] 143 | let errors = getErrors schema doc 144 | errors `shouldBe` [MixedAnonymousOperations 2 []] 145 | formatErrors errors `shouldBe` ["Multiple anonymous operations defined. Found 2"] 146 | 147 | it "Detects mixed operations" $ do 148 | let doc = AST.QueryDocument 149 | [ AST.DefinitionOperation 150 | ( AST.AnonymousQuery 151 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 152 | ] 153 | ) 154 | , AST.DefinitionOperation 155 | ( AST.Query (AST.Node (pure "houseTrainedQuery") [] [] 156 | [ AST.SelectionField (AST.Field Nothing someName [] [] []) 157 | ] 158 | )) 159 | ] 160 | let errors = getErrors schema doc 161 | errors `shouldBe` [MixedAnonymousOperations 1 [Just "houseTrainedQuery"]] 162 | formatErrors errors `shouldBe` ["Document contains both anonymous operations (1) and named operations ([Just (Name {unName = \"houseTrainedQuery\"})])"] 163 | 164 | it "Detects non-existing type in variable definition" $ do 165 | let doc = AST.QueryDocument 166 | [ AST.DefinitionOperation 167 | (AST.Query 168 | (AST.Node Nothing 169 | [ AST.VariableDefinition 170 | (AST.Variable "atOtherHomes") 171 | (AST.TypeNamed (AST.NamedType "MyNonExistingType")) 172 | (Just (AST.ValueBoolean True)) 173 | ] [] 174 | [ AST.SelectionField 175 | (AST.Field Nothing dog [] [] 176 | [ AST.SelectionField 177 | (AST.Field Nothing "isHousetrained" 178 | [ AST.Argument "atOtherHomes" 179 | (AST.ValueVariable (AST.Variable "atOtherHomes")) 180 | ] [] []) 181 | ]) 182 | ])) 183 | ] 184 | getErrors schema doc `shouldBe` [VariableTypeNotFound (AST.Variable "atOtherHomes") "MyNonExistingType"] 185 | 186 | it "Detects unused variable definition" $ do 187 | let doc = AST.QueryDocument 188 | [ AST.DefinitionOperation 189 | (AST.Query 190 | (AST.Node Nothing 191 | [ AST.VariableDefinition 192 | (AST.Variable "atOtherHomes") 193 | (AST.TypeNamed (AST.NamedType "String")) 194 | (Just (AST.ValueBoolean True)) 195 | ] [] 196 | [ AST.SelectionField 197 | (AST.Field Nothing dog [] [] 198 | [ AST.SelectionField 199 | (AST.Field Nothing "isHousetrained" 200 | [] [] []) 201 | ]) 202 | ])) 203 | ] 204 | getErrors schema doc `shouldBe` [UnusedVariables (Set.fromList [AST.Variable "atOtherHomes"])] 205 | 206 | it "Treats anonymous queries with inline arguments as valid" $ do 207 | let doc = AST.QueryDocument 208 | [ AST.DefinitionOperation 209 | (AST.Query 210 | (AST.Node Nothing 211 | [] [] 212 | [ AST.SelectionField 213 | (AST.Field Nothing dog [] [] 214 | [ AST.SelectionField 215 | (AST.Field Nothing "isHousetrained" 216 | [ AST.Argument "atOtherHomes" 217 | (AST.ValueList (AST.ListValue [ 218 | (AST.ValueObject (AST.ObjectValue [ 219 | (AST.ObjectField "testKey" (AST.ValueInt 123)), 220 | (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) 221 | ])) 222 | ])) 223 | ] [] []) 224 | ]) 225 | ])) 226 | ] 227 | getErrors schema doc `shouldBe` [] 228 | it "Detects non-existent fragment type" $ do 229 | let doc = AST.QueryDocument 230 | [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" 231 | (AST.NamedType "Dog") [] [ 232 | AST.SelectionField (AST.Field Nothing "name" [] [] []) 233 | ])), 234 | (AST.DefinitionOperation 235 | (AST.Query 236 | (AST.Node Nothing 237 | [] [] 238 | [AST.SelectionField 239 | (AST.Field Nothing dog [] [] 240 | [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) 241 | ]) 242 | ]))) 243 | ] 244 | getErrors schema doc `shouldBe` [TypeConditionNotFound "Dog"] 245 | 246 | describe "findDuplicates" $ do 247 | prop "returns empty on unique lists" $ do 248 | \xs -> findDuplicates @Int (ordNub xs) === [] 249 | prop "finds only duplicates" $ \xs -> do 250 | all (>1) (count xs <$> findDuplicates @Int xs) 251 | prop "finds all duplicates" $ \xs -> do 252 | (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs 253 | 254 | 255 | -- | Count the number of times 'x' occurs in 'xs'. 256 | count :: Eq a => [a] -> a -> Int 257 | count xs x = (length . filter (== x)) xs 258 | -------------------------------------------------------------------------------- /tests/ValueSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module ValueSpec (spec) where 3 | 4 | import Protolude 5 | 6 | import Test.Hspec.QuickCheck (prop) 7 | import Test.QuickCheck (forAll) 8 | import Test.Hspec 9 | 10 | import qualified GraphQL.Internal.Syntax.AST as AST 11 | import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty) 12 | import GraphQL.Value 13 | ( Object 14 | , Value'(ValueObject') 15 | , ObjectField'(..) 16 | , astToVariableValue 17 | , unionObjects 18 | , objectFields 19 | , objectFromList 20 | , toValue 21 | ) 22 | import GraphQL.Internal.Value.FromValue (FromValue(..), prop_roundtripValue) 23 | 24 | data Resource = Resource 25 | { resText :: Text 26 | , resInt :: Int32 27 | , resDouble :: Double 28 | , resBool :: Bool 29 | } deriving (Generic, Eq, Show) 30 | 31 | instance FromValue Resource 32 | 33 | spec :: Spec 34 | spec = describe "Value" $ do 35 | describe "unionObject" $ do 36 | it "returns empty on empty list" $ do 37 | unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) 38 | it "merges objects" $ do 39 | let (Just foo) = objectFromList [ ("foo", toValue @Int32 1) 40 | , ("bar",toValue @Int32 2)] 41 | let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") 42 | , ("baz",toValue @Int32 3)] 43 | let observed = unionObjects [foo, bar] 44 | observed `shouldBe` Nothing 45 | it "merges objects with unique keys" $ do 46 | let (Just foo) = objectFromList [("foo", toValue @Int32 1)] 47 | let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") 48 | , ("baz",toValue @Int32 3)] 49 | let (Just expected) = objectFromList [ ("foo", toValue @Int32 1) 50 | , ("bar", toValue @Text "cow") 51 | , ("baz", toValue @Int32 3) 52 | ] 53 | let (Just observed) = unionObjects [foo, bar] 54 | observed `shouldBe` expected 55 | expected `shouldSatisfy` prop_fieldsUnique 56 | describe "Objects" $ do 57 | prop "have unique fields" $ do 58 | prop_fieldsUnique 59 | -- See https://github.com/haskell-graphql/graphql-api/pull/178 for background 60 | it "derives fromValue instances for objects with more than three fields" $ do 61 | let Just value = objectFromList 62 | [ ("resText", toValue @Text "text") 63 | , ("resBool", toValue @Bool False) 64 | , ("resDouble", toValue @Double 1.2) 65 | , ("resInt", toValue @Int32 32) 66 | ] 67 | let Right observed = fromValue $ ValueObject' value 68 | let expected = Resource 69 | { resText = "text" 70 | , resInt = 32 71 | , resDouble = 1.2 72 | , resBool = False 73 | } 74 | observed `shouldBe` expected 75 | 76 | describe "ToValue / FromValue instances" $ do 77 | prop "Bool" $ prop_roundtripValue @Bool 78 | prop "Int32" $ prop_roundtripValue @Int32 79 | prop "Double" $ prop_roundtripValue @Double 80 | prop "Text" $ forAll arbitraryText prop_roundtripValue 81 | prop "Lists" $ prop_roundtripValue @[Int32] 82 | prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue 83 | describe "AST" $ do 84 | it "Objects converted from AST have unique fields" $ do 85 | let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar")) 86 | , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux")) 87 | ] 88 | astToVariableValue (AST.ValueObject input) `shouldBe` Nothing 89 | 90 | 91 | -- | All of the fields in an object should have unique names. 92 | prop_fieldsUnique :: Object -> Bool 93 | prop_fieldsUnique object = 94 | fieldNames == ordNub fieldNames 95 | where 96 | fieldNames = [name | ObjectField name _ <- objectFields object] 97 | -------------------------------------------------------------------------------- /tests/doctests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Protolude 4 | 5 | import Test.DocTest 6 | 7 | main :: IO () 8 | main = doctest $ ["-isrc"] <> options <> files 9 | where 10 | options = map ("-X" <>) extensions 11 | -- These must match the extensions in package.yaml. 12 | extensions = [ "NoImplicitPrelude" 13 | , "OverloadedStrings" 14 | , "RecordWildCards" 15 | , "TypeApplications" 16 | , "DataKinds" 17 | ] 18 | -- library code 19 | files = [ "src/" ] 20 | --------------------------------------------------------------------------------