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