Compare commits
47 Commits
Author | SHA1 | Date | |
---|---|---|---|
1c4584abdd
|
|||
e071553e75
|
|||
e731c7db07
|
|||
303cf18d77
|
|||
6b8346e527
|
|||
303f84ed41
|
|||
d2ea9fb467
|
|||
809f446ff1
|
|||
b1b6bfcdb9
|
|||
59aa010f0b | |||
b1c5a568dd
|
|||
5ffe8c72fa
|
|||
a961b168db | |||
a1cda38e20 | |||
7c78497e04 | |||
fdc43e4e25 | |||
2fdf04f54a
|
|||
3ed7dcd401
|
|||
408dfb4301
|
|||
3b69dac371
|
|||
2834360411
|
|||
83f2dc1a2d
|
|||
3b0da4f3d7
|
|||
d83f75b341
|
|||
85d876e131
|
|||
05fa5df558
|
|||
9021f3a25d
|
|||
025331a9ee
|
|||
ab4808c44d
|
|||
bb4375313e
|
|||
70dedb6911
|
|||
a96d4e6ef3
|
|||
3ce6e7da46
|
|||
a5cf0a32e8
|
|||
2f9881bb21
|
|||
bf2e4925b4
|
|||
2321d1a1bc
|
|||
2f19093803
|
|||
0dac9701bc
|
|||
0d25f482dd
|
|||
a2401d563b
|
|||
8503c0f288 | |||
05e6aa4c95 | |||
647547206f
|
|||
0c8edae90a | |||
73585dde85
|
|||
1f7bd92d11 |
52
.gitea/workflows/build.yml
Normal file
52
.gitea/workflows/build.yml
Normal file
@ -0,0 +1,52 @@
|
||||
name: Build
|
||||
|
||||
on:
|
||||
push:
|
||||
branches:
|
||||
- '**'
|
||||
pull_request:
|
||||
branches: [master]
|
||||
|
||||
jobs:
|
||||
audit:
|
||||
runs-on: haskell
|
||||
steps:
|
||||
- name: Set up environment
|
||||
run: |
|
||||
apt-get update -y
|
||||
apt-get upgrade -y
|
||||
apt-get install -y nodejs pkg-config
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: |
|
||||
cabal update
|
||||
cabal install hlint "--constraint=hlint ==3.8"
|
||||
- run: cabal exec hlint -- src tests
|
||||
|
||||
test:
|
||||
runs-on: haskell
|
||||
steps:
|
||||
- name: Set up environment
|
||||
run: |
|
||||
apt-get update -y
|
||||
apt-get upgrade -y
|
||||
apt-get install -y nodejs pkg-config
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: cabal update
|
||||
- name: Prepare system
|
||||
run: cabal build graphql-test
|
||||
- run: cabal test --test-show-details=streaming
|
||||
|
||||
doc:
|
||||
runs-on: haskell
|
||||
steps:
|
||||
- name: Set up environment
|
||||
run: |
|
||||
apt-get update -y
|
||||
apt-get upgrade -y
|
||||
apt-get install -y nodejs pkg-config
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: cabal update
|
||||
- run: cabal haddock --enable-documentation
|
23
.gitea/workflows/release.yml
Normal file
23
.gitea/workflows/release.yml
Normal file
@ -0,0 +1,23 @@
|
||||
name: Release
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- '**'
|
||||
|
||||
jobs:
|
||||
release:
|
||||
runs-on: haskell
|
||||
steps:
|
||||
- name: Set up environment
|
||||
run: |
|
||||
apt-get update -y
|
||||
apt-get upgrade -y
|
||||
apt-get install -y nodejs pkg-config
|
||||
- uses: actions/checkout@v4
|
||||
- name: Upload a candidate
|
||||
env:
|
||||
HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }}
|
||||
run: |
|
||||
cabal sdist
|
||||
cabal upload --username belka --password ${HACKAGE_PASSWORD}
|
103
CHANGELOG.md
103
CHANGELOG.md
@ -6,6 +6,65 @@ The format is based on
|
||||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [1.3.0.0] - 2024-05-01
|
||||
### Changed
|
||||
- Remove deprecated `runCollectErrs`, `Resolution`, `CollectErrsT` from the
|
||||
`Error` module.
|
||||
|
||||
## [1.2.0.3] - 2024-01-09
|
||||
### Fixed
|
||||
- Fix corrupted source distribution.
|
||||
|
||||
## [1.2.0.2] - 2024-01-09
|
||||
### Fixed
|
||||
- `gql` removes not only leading `\n` but also `\r`.
|
||||
- Fix non nullable type string representation in executor error messages.
|
||||
- Fix input objects not being coerced to lists.
|
||||
- Fix used variables are not found in the properties of input objects.
|
||||
|
||||
## [1.2.0.1] - 2023-04-25
|
||||
### Fixed
|
||||
- Support hspec 2.11.
|
||||
|
||||
## [1.2.0.0] - 2023-02-28
|
||||
### Added
|
||||
- Schema printing.
|
||||
- `Semigroup` and `Monoid` instances for `AST.Document.Description`.
|
||||
- Support for vector 0.13.0.0 and transformers 0.6.1.0.
|
||||
|
||||
### Fixed
|
||||
- Fix resolvers returning a list in the reverse order.
|
||||
|
||||
### Removed
|
||||
- GHC 8 support.
|
||||
- Cabal -json flag.
|
||||
- `Test.Hspec.GraphQL`: moved to `graphql-spice` package.
|
||||
- CPP `ifdef WITH_JSON` blocks.
|
||||
|
||||
## [1.1.0.0] - 2022-12-24
|
||||
### Changed
|
||||
- Removed deprecated `Language.GraphQL.Error` functions: `addErr`, `addErrMsg`,
|
||||
`singleError`.
|
||||
- Deprecate `Resolution`, `CollectErrsT` and `runCollectErrs` in the `Error`
|
||||
module. It was already noted in the documentation that these symbols are
|
||||
deprecated, now a pragma is added.
|
||||
- `Language.GraphQL`: Added information about the *json* flag and switching to
|
||||
*graphql-spice* for JSON support.
|
||||
|
||||
### Added
|
||||
- Partial schema printing: operation type encoder.
|
||||
|
||||
## [1.0.3.0] - 2022-03-27
|
||||
### Fixed
|
||||
- Index position in error path. (Index and Segment paths of a field have been
|
||||
swapped).
|
||||
- Parsing empty list as an argument.
|
||||
|
||||
### Added
|
||||
- quickCheck Parser test for arguments. Arbitrary instances for Language.GraphQL.AST.Document.
|
||||
- Enhanced query error messages. Add tests for these cases.
|
||||
- Allow version 2.0 of the text package.
|
||||
|
||||
## [1.0.2.0] - 2021-12-26
|
||||
### Added
|
||||
- `Serialize` instance for `Type.Definition.Value`.
|
||||
@ -361,7 +420,6 @@ and this project adheres to
|
||||
- `Language.GraphQL.Schema`: `enum`, `enumA`, `wrappedEnum` and `wrappedEnumA`.
|
||||
Use `scalar`, `scalarA`, `wrappedScalar` and `wrappedScalarA` instead.
|
||||
|
||||
|
||||
## [0.5.1.0] - 2019-10-22
|
||||
### Deprecated
|
||||
- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`
|
||||
@ -466,21 +524,28 @@ and this project adheres to
|
||||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.2.0&rev_to=v1.0.1.0
|
||||
[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0
|
||||
[1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0
|
||||
[0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0
|
||||
[0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0
|
||||
[0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0
|
||||
[0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0
|
||||
[0.8.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.8.0.0&rev_to=v0.7.0.0
|
||||
[0.7.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.7.0.0&rev_to=v0.6.1.0
|
||||
[0.6.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.1.0&rev_to=v0.6.0.0
|
||||
[0.6.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.0.0&rev_to=v0.5.1.0
|
||||
[0.5.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.1.0&rev_to=v0.5.0.1
|
||||
[0.5.0.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.1&rev_to=v0.5.0.0
|
||||
[0.5.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.0&rev_to=v0.4.0.0
|
||||
[0.4.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.4.0.0&rev_to=v0.3
|
||||
[0.3]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.3&rev_to=v0.2.1
|
||||
[0.2.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2.1&rev_to=v0.2
|
||||
[0.2]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2&rev_to=v0.1
|
||||
[1.3.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.3...v1.3.0.0
|
||||
[1.2.0.3]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.2...v1.2.0.3
|
||||
[1.2.0.2]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...v1.2.0.2
|
||||
[1.2.0.1]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.0...v1.2.0.1
|
||||
[1.2.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.1.0.0...v1.2.0.0
|
||||
[1.1.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.3.0...v1.1.0.0
|
||||
[1.0.3.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.2.0...v1.0.3.0
|
||||
[1.0.2.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.1.0...v1.0.2.0
|
||||
[1.0.1.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.0.0...v1.0.1.0
|
||||
[1.0.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.11.1.0...v1.0.0.0
|
||||
[0.11.1.0]: https://git.caraus.tech/OSS/graphql/compare/v0.11.0.0...v0.11.1.0
|
||||
[0.11.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.10.0.0...v0.11.0.0
|
||||
[0.10.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.9.0.0...v0.10.0.0
|
||||
[0.9.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.8.0.0...v0.9.0.0
|
||||
[0.8.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.7.0.0...v0.8.0.0
|
||||
[0.7.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.6.1.0...v0.7.0.0
|
||||
[0.6.1.0]: https://git.caraus.tech/OSS/graphql/compare/v0.6.0.0...v0.6.1.0
|
||||
[0.6.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.5.1.0...v0.6.0.0
|
||||
[0.5.1.0]: https://git.caraus.tech/OSS/graphql/compare/v0.5.0.1...v0.5.1.0
|
||||
[0.5.0.1]: https://git.caraus.tech/OSS/graphql/compare/v0.5.0.0...v0.5.0.1
|
||||
[0.5.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.4.0.0...v0.5.0.0
|
||||
[0.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v0.3...v0.4.0.0
|
||||
[0.3]: https://git.caraus.tech/OSS/graphql/compare/v0.2.1...v0.3
|
||||
[0.2.1]: https://git.caraus.tech/OSS/graphql/compare/v0.2...v0.2.1
|
||||
[0.2]: https://git.caraus.tech/OSS/graphql/compare/v0.1...v0.2
|
||||
|
@ -1,15 +1,12 @@
|
||||
# GraphQL implementation in Haskell
|
||||
|
||||
[](https://www.simplehaskell.org)
|
||||
[](https://build.caraus.tech/go/pipelines)
|
||||
|
||||
See https://www.caraus.tech/projects/pub-graphql.
|
||||
See https://git.caraus.tech/OSS/graphql.
|
||||
|
||||
Report issues on the
|
||||
[bug tracker](https://www.caraus.tech/projects/pub-graphql/issues).
|
||||
[bug tracker](https://git.caraus.tech/OSS/graphql/issues).
|
||||
|
||||
API documentation is available through
|
||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||
|
||||
Further documentation will be made available in the
|
||||
[Wiki](https://www.caraus.tech/projects/pub-graphql/wiki).
|
||||
[Wiki](https://git.caraus.tech/OSS/graphql/wiki).
|
||||
|
@ -1,17 +1,17 @@
|
||||
cabal-version: 2.4
|
||||
|
||||
name: graphql
|
||||
version: 1.0.2.0
|
||||
version: 1.3.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||
homepage: https://git.caraus.tech/OSS/graphql
|
||||
bug-reports: https://git.caraus.tech/OSS/graphql/issues
|
||||
author: Danny Navarro <j@dannynavarro.net>,
|
||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019-2021 Eugen Wissner,
|
||||
copyright: (c) 2019-2024 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
license-files: LICENSE,
|
||||
@ -21,18 +21,12 @@ extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
tested-with:
|
||||
GHC == 8.10.7,
|
||||
GHC == 9.0.1,
|
||||
GHC == 9.2.1
|
||||
GHC == 9.4.7,
|
||||
GHC == 9.6.3
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://caraus.tech/pub/graphql.git
|
||||
|
||||
flag Json
|
||||
description: Whether to build against @aeson 1.x@
|
||||
default: True
|
||||
manual: True
|
||||
location: https://git.caraus.tech/OSS/graphql.git
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
@ -54,7 +48,6 @@ library
|
||||
Language.GraphQL.Type.Schema
|
||||
Language.GraphQL.Validate
|
||||
Language.GraphQL.Validate.Validation
|
||||
Test.Hspec.GraphQL
|
||||
other-modules:
|
||||
Language.GraphQL.Execute.Transform
|
||||
Language.GraphQL.Type.Definition
|
||||
@ -67,21 +60,15 @@ library
|
||||
build-depends:
|
||||
base >= 4.7 && < 5,
|
||||
conduit ^>= 1.3.4,
|
||||
containers ^>= 0.6.2,
|
||||
containers >= 0.6 && < 0.8,
|
||||
exceptions ^>= 0.10.4,
|
||||
megaparsec >= 9.0 && < 10,
|
||||
parser-combinators >= 1.3 && < 2,
|
||||
template-haskell >= 2.16 && < 3,
|
||||
text ^>= 1.2.4,
|
||||
transformers ^>= 0.5.6,
|
||||
text >= 1.2 && < 3,
|
||||
transformers >= 0.5.6 && < 0.7,
|
||||
unordered-containers ^>= 0.2.14,
|
||||
vector ^>= 0.12.3
|
||||
if flag(Json)
|
||||
build-depends:
|
||||
aeson >= 1.5.6 && < 1.6,
|
||||
hspec-expectations >= 0.8.2 && < 0.9,
|
||||
scientific >= 0.3.7 && < 0.4
|
||||
cpp-options: -DWITH_JSON
|
||||
vector >= 0.12 && < 0.14
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -93,25 +80,32 @@ test-suite graphql-test
|
||||
Language.GraphQL.AST.EncoderSpec
|
||||
Language.GraphQL.AST.LexerSpec
|
||||
Language.GraphQL.AST.ParserSpec
|
||||
Language.GraphQL.AST.Arbitrary
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.Execute.CoerceSpec
|
||||
Language.GraphQL.Execute.OrderedMapSpec
|
||||
Language.GraphQL.ExecuteSpec
|
||||
Language.GraphQL.Type.OutSpec
|
||||
Language.GraphQL.Validate.RulesSpec
|
||||
Schemas.HeroSchema
|
||||
hs-source-dirs:
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||
|
||||
build-depends:
|
||||
QuickCheck ^>= 2.14.1,
|
||||
QuickCheck >= 2.14 && < 2.16,
|
||||
base,
|
||||
conduit,
|
||||
exceptions,
|
||||
graphql,
|
||||
hspec ^>= 2.9.1,
|
||||
hspec >= 2.10.9 && < 2.12,
|
||||
hspec-expectations ^>= 0.8.2,
|
||||
hspec-megaparsec ^>= 2.2.0,
|
||||
megaparsec,
|
||||
text,
|
||||
unordered-containers
|
||||
unordered-containers,
|
||||
containers,
|
||||
vector
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
default-language: Haskell2010
|
||||
|
@ -1,84 +1,46 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
#ifdef WITH_JSON
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
module Language.GraphQL
|
||||
( graphql
|
||||
, graphqlSubs
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST
|
||||
import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import qualified Language.GraphQL.Validate as Validate
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema'.
|
||||
graphql :: MonadCatch m
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
|
||||
graphql schema = graphqlSubs schema mempty mempty
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the substitution is
|
||||
-- applied to the query and the query is then executed using to the given
|
||||
-- 'Schema'.
|
||||
graphqlSubs :: MonadCatch m
|
||||
--
|
||||
-- An operation name can be given if the document contains multiple operations.
|
||||
graphql :: (MonadCatch m, VariableValue a, Serialize b)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> Aeson.Object -- ^ Variable substitution function.
|
||||
-> HashMap Full.Name a -- ^ Variable substitution function.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
|
||||
graphqlSubs schema operationName variableValues document' =
|
||||
case parse document "" document' of
|
||||
Left errorBundle -> pure . formatResponse <$> parseError errorBundle
|
||||
-> m (Either (ResponseEventStream m b) (Response b)) -- ^ Response.
|
||||
graphql schema operationName variableValues document' =
|
||||
case parse Full.document "" document' of
|
||||
Left errorBundle -> pure <$> parseError errorBundle
|
||||
Right parsed ->
|
||||
case validate parsed of
|
||||
Seq.Empty -> fmap formatResponse
|
||||
<$> execute schema operationName variableValues parsed
|
||||
Seq.Empty -> execute schema operationName variableValues parsed
|
||||
errors -> pure $ pure
|
||||
$ HashMap.singleton "errors"
|
||||
$ Aeson.toJSON
|
||||
$ Response null
|
||||
$ fromValidationError <$> errors
|
||||
where
|
||||
validate = Validate.document schema Validate.specifiedRules
|
||||
formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
|
||||
formatResponse (Response data'' errors') = HashMap.fromList
|
||||
[ ("data", data'')
|
||||
, ("errors", Aeson.toJSON $ fromError <$> errors')
|
||||
]
|
||||
fromError Error{..} = Aeson.object $ catMaybes
|
||||
[ Just ("message", Aeson.toJSON message)
|
||||
, toMaybe fromLocation "locations" locations
|
||||
, toMaybe fromPath "path" path
|
||||
]
|
||||
fromValidationError Validate.Error{..} = Aeson.object
|
||||
[ ("message", Aeson.toJSON message)
|
||||
, ("locations", Aeson.listValue fromLocation locations)
|
||||
]
|
||||
toMaybe _ _ [] = Nothing
|
||||
toMaybe f key xs = Just (key, Aeson.listValue f xs)
|
||||
fromPath (Segment segment) = Aeson.String segment
|
||||
fromPath (Index index) = Aeson.toJSON index
|
||||
fromLocation Location{..} = Aeson.object
|
||||
[ ("line", Aeson.toJSON line)
|
||||
, ("column", Aeson.toJSON column)
|
||||
]
|
||||
#else
|
||||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
module Language.GraphQL
|
||||
(
|
||||
) where
|
||||
#endif
|
||||
fromValidationError Validate.Error{..} = Error
|
||||
{ message = Text.pack message
|
||||
, locations = locations
|
||||
, path = []
|
||||
}
|
||||
|
@ -49,6 +49,8 @@ module Language.GraphQL.AST.Document
|
||||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
, escape
|
||||
, showVariableName
|
||||
, showVariable
|
||||
) where
|
||||
|
||||
import Data.Char (ord)
|
||||
@ -339,6 +341,12 @@ data VariableDefinition =
|
||||
VariableDefinition Name Type (Maybe (Node ConstValue)) Location
|
||||
deriving (Eq, Show)
|
||||
|
||||
showVariableName :: VariableDefinition -> String
|
||||
showVariableName (VariableDefinition name _ _ _) = "$" <> Text.unpack name
|
||||
|
||||
showVariable :: VariableDefinition -> String
|
||||
showVariable var@(VariableDefinition _ type' _ _) = showVariableName var <> ":" <> " " <> show type'
|
||||
|
||||
-- ** Type References
|
||||
|
||||
-- | Type representation.
|
||||
@ -363,8 +371,8 @@ data NonNullType
|
||||
deriving Eq
|
||||
|
||||
instance Show NonNullType where
|
||||
show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName
|
||||
show (NonNullTypeList listType) = concat ["![", show listType, "]"]
|
||||
show (NonNullTypeNamed typeName) = Text.unpack $ typeName <> "!"
|
||||
show (NonNullTypeList listType) = concat ["[", show listType, "]!"]
|
||||
|
||||
-- ** Directives
|
||||
|
||||
@ -456,6 +464,14 @@ data SchemaExtension
|
||||
newtype Description = Description (Maybe Text)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Semigroup Description
|
||||
where
|
||||
Description lhs <> Description rhs = Description $ lhs <> rhs
|
||||
|
||||
instance Monoid Description
|
||||
where
|
||||
mempty = Description mempty
|
||||
|
||||
-- ** Types
|
||||
|
||||
-- | Type definitions describe various user-defined types.
|
||||
|
@ -11,12 +11,14 @@ module Language.GraphQL.AST.Encoder
|
||||
, directive
|
||||
, document
|
||||
, minified
|
||||
, operationType
|
||||
, pretty
|
||||
, type'
|
||||
, typeSystemDefinition
|
||||
, value
|
||||
) where
|
||||
|
||||
import Data.Foldable (fold)
|
||||
import Data.Foldable (fold, Foldable (..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
@ -27,6 +29,7 @@ import qualified Data.Text.Lazy.Builder as Builder
|
||||
import Data.Text.Lazy.Builder.Int (decimal)
|
||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
|
||||
-- | Instructs the encoder whether the GraphQL document should be minified or
|
||||
-- pretty printed.
|
||||
@ -34,7 +37,7 @@ import qualified Language.GraphQL.AST.Document as Full
|
||||
-- Use 'pretty' or 'minified' to construct the formatter.
|
||||
data Formatter
|
||||
= Minified
|
||||
| Pretty Word
|
||||
| Pretty !Word
|
||||
|
||||
-- | Constructs a formatter for pretty printing.
|
||||
pretty :: Formatter
|
||||
@ -53,7 +56,246 @@ document formatter defs
|
||||
encodeDocument = foldr executableDefinition [] defs
|
||||
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
|
||||
definition formatter executableDefinition' : acc
|
||||
executableDefinition _ acc = acc
|
||||
executableDefinition (Full.TypeSystemDefinition typeSystemDefinition' _location) acc =
|
||||
typeSystemDefinition formatter typeSystemDefinition' : acc
|
||||
executableDefinition (Full.TypeSystemExtension typeSystemExtension' _location) acc =
|
||||
typeSystemExtension formatter typeSystemExtension' : acc
|
||||
|
||||
directiveLocation :: DirectiveLocation.DirectiveLocation -> Lazy.Text
|
||||
directiveLocation = Lazy.Text.pack . show
|
||||
|
||||
withLineBreak :: Formatter -> Lazy.Text.Text -> Lazy.Text.Text
|
||||
withLineBreak formatter encodeDefinition
|
||||
| Pretty _ <- formatter = Lazy.Text.snoc encodeDefinition '\n'
|
||||
| Minified <- formatter = encodeDefinition
|
||||
|
||||
typeSystemExtension :: Formatter -> Full.TypeSystemExtension -> Lazy.Text
|
||||
typeSystemExtension formatter = \case
|
||||
Full.SchemaExtension schemaExtension' ->
|
||||
schemaExtension formatter schemaExtension'
|
||||
Full.TypeExtension typeExtension' -> typeExtension formatter typeExtension'
|
||||
|
||||
schemaExtension :: Formatter -> Full.SchemaExtension -> Lazy.Text
|
||||
schemaExtension formatter = \case
|
||||
Full.SchemaOperationExtension operationDirectives operationTypeDefinitions' ->
|
||||
withLineBreak formatter
|
||||
$ "extend schema "
|
||||
<> optempty (directives formatter) operationDirectives
|
||||
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
||||
Full.SchemaDirectivesExtension operationDirectives -> "extend schema "
|
||||
<> optempty (directives formatter) (NonEmpty.toList operationDirectives)
|
||||
|
||||
typeExtension :: Formatter -> Full.TypeExtension -> Lazy.Text
|
||||
typeExtension formatter = \case
|
||||
Full.ScalarTypeExtension name' directives'
|
||||
-> "extend scalar "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> directives formatter (NonEmpty.toList directives')
|
||||
Full.ObjectTypeFieldsDefinitionExtension name' ifaces' directives' fields'
|
||||
-> "extend type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
|
||||
Full.ObjectTypeDirectivesExtension name' ifaces' directives'
|
||||
-> "extend type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.ObjectTypeImplementsInterfacesExtension name' ifaces'
|
||||
-> "extend type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
Full.InterfaceTypeFieldsDefinitionExtension name' directives' fields'
|
||||
-> "extend interface "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
|
||||
Full.InterfaceTypeDirectivesExtension name' directives'
|
||||
-> "extend interface "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.UnionTypeUnionMemberTypesExtension name' directives' members'
|
||||
-> "extend union "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> unionMemberTypes formatter members'
|
||||
Full.UnionTypeDirectivesExtension name' directives'
|
||||
-> "extend union "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.EnumTypeEnumValuesDefinitionExtension name' directives' members'
|
||||
-> "extend enum "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (enumValueDefinition formatter) (NonEmpty.toList members')
|
||||
Full.EnumTypeDirectivesExtension name' directives'
|
||||
-> "extend enum "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
Full.InputObjectTypeInputFieldsDefinitionExtension name' directives' fields'
|
||||
-> "extend input "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (inputValueDefinition nextFormatter) (NonEmpty.toList fields')
|
||||
Full.InputObjectTypeDirectivesExtension name' directives'
|
||||
-> "extend input "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) (NonEmpty.toList directives')
|
||||
where
|
||||
nextFormatter = incrementIndent formatter
|
||||
|
||||
-- | Converts a t'Full.TypeSystemDefinition' into a string.
|
||||
typeSystemDefinition :: Formatter -> Full.TypeSystemDefinition -> Lazy.Text
|
||||
typeSystemDefinition formatter = \case
|
||||
Full.SchemaDefinition operationDirectives operationTypeDefinitions' ->
|
||||
withLineBreak formatter
|
||||
$ "schema "
|
||||
<> optempty (directives formatter) operationDirectives
|
||||
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
||||
Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
|
||||
Full.DirectiveDefinition description' name' arguments' locations
|
||||
-> description formatter description'
|
||||
<> "@"
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> argumentsDefinition formatter arguments'
|
||||
<> " on"
|
||||
<> pipeList formatter (directiveLocation <$> locations)
|
||||
|
||||
operationTypeDefinition :: Formatter -> Full.OperationTypeDefinition -> Lazy.Text.Text
|
||||
operationTypeDefinition formatter (Full.OperationTypeDefinition operationType' namedType')
|
||||
= indentLine (incrementIndent formatter)
|
||||
<> operationType formatter operationType'
|
||||
<> colon formatter
|
||||
<> Lazy.Text.fromStrict namedType'
|
||||
|
||||
fieldDefinition :: Formatter -> Full.FieldDefinition -> Lazy.Text.Text
|
||||
fieldDefinition formatter fieldDefinition' =
|
||||
let Full.FieldDefinition description' name' arguments' type'' directives' = fieldDefinition'
|
||||
in optempty (description formatter) description'
|
||||
<> indentLine formatter
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> argumentsDefinition formatter arguments'
|
||||
<> colon formatter
|
||||
<> type' type''
|
||||
<> optempty (directives formatter) directives'
|
||||
|
||||
argumentsDefinition :: Formatter -> Full.ArgumentsDefinition -> Lazy.Text.Text
|
||||
argumentsDefinition formatter (Full.ArgumentsDefinition arguments') =
|
||||
parensCommas formatter (argumentDefinition formatter) arguments'
|
||||
|
||||
argumentDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
|
||||
argumentDefinition formatter definition' =
|
||||
let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
|
||||
in optempty (description formatter) description'
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> colon formatter
|
||||
<> type' type''
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
<> directives formatter directives'
|
||||
|
||||
inputValueDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
|
||||
inputValueDefinition formatter definition' =
|
||||
let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
|
||||
in optempty (description formatter) description'
|
||||
<> indentLine formatter
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> colon formatter
|
||||
<> type' type''
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
<> directives formatter directives'
|
||||
|
||||
typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text
|
||||
typeDefinition formatter = \case
|
||||
Full.ScalarTypeDefinition description' name' directives'
|
||||
-> optempty (description formatter) description'
|
||||
<> "scalar "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
Full.ObjectTypeDefinition description' name' ifaces' directives' fields'
|
||||
-> optempty (description formatter) description'
|
||||
<> "type "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
||||
Full.InterfaceTypeDefinition description' name' directives' fields'
|
||||
-> optempty (description formatter) description'
|
||||
<> "interface "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
||||
Full.UnionTypeDefinition description' name' directives' members'
|
||||
-> optempty (description formatter) description'
|
||||
<> "union "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> unionMemberTypes formatter members'
|
||||
Full.EnumTypeDefinition description' name' directives' members'
|
||||
-> optempty (description formatter) description'
|
||||
<> "enum "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (enumValueDefinition formatter) members'
|
||||
Full.InputObjectTypeDefinition description' name' directives' fields'
|
||||
-> optempty (description formatter) description'
|
||||
<> "input "
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> optempty (directives formatter) directives'
|
||||
<> eitherFormat formatter " " ""
|
||||
<> bracesList formatter (inputValueDefinition nextFormatter) fields'
|
||||
where
|
||||
nextFormatter = incrementIndent formatter
|
||||
|
||||
implementsInterfaces :: Foldable t => Full.ImplementsInterfaces t -> Lazy.Text
|
||||
implementsInterfaces (Full.ImplementsInterfaces interfaces)
|
||||
| null interfaces = mempty
|
||||
| otherwise = Lazy.Text.fromStrict
|
||||
$ Text.append "implements "
|
||||
$ Text.intercalate " & "
|
||||
$ toList interfaces
|
||||
|
||||
unionMemberTypes :: Foldable t => Formatter -> Full.UnionMemberTypes t -> Lazy.Text
|
||||
unionMemberTypes formatter (Full.UnionMemberTypes memberTypes)
|
||||
| null memberTypes = mempty
|
||||
| otherwise = Lazy.Text.append "="
|
||||
$ pipeList formatter
|
||||
$ Lazy.Text.fromStrict
|
||||
<$> toList memberTypes
|
||||
|
||||
pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text
|
||||
pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList
|
||||
pipeList (Pretty _) = Lazy.Text.concat
|
||||
. fmap (("\n" <> indentSymbol <> "| ") <>)
|
||||
. toList
|
||||
|
||||
enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text
|
||||
enumValueDefinition (Pretty _) enumValue =
|
||||
let Full.EnumValueDefinition description' name' directives' = enumValue
|
||||
formatter = Pretty 1
|
||||
in description formatter description'
|
||||
<> indentLine formatter
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> directives formatter directives'
|
||||
enumValueDefinition Minified enumValue =
|
||||
let Full.EnumValueDefinition description' name' directives' = enumValue
|
||||
in description Minified description'
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> directives Minified directives'
|
||||
|
||||
description :: Formatter -> Full.Description -> Lazy.Text.Text
|
||||
description _formatter (Full.Description Nothing) = ""
|
||||
description formatter (Full.Description (Just description')) =
|
||||
stringValue formatter description'
|
||||
|
||||
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
|
||||
@ -99,9 +341,9 @@ variableDefinition formatter variableDefinition' =
|
||||
let Full.VariableDefinition variableName variableType defaultValue' _ =
|
||||
variableDefinition'
|
||||
in variable variableName
|
||||
<> eitherFormat formatter ": " ":"
|
||||
<> colon formatter
|
||||
<> type' variableType
|
||||
<> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue')
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
|
||||
defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
|
||||
defaultValue formatter val
|
||||
@ -126,20 +368,26 @@ indent :: (Integral a) => a -> Lazy.Text
|
||||
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
||||
|
||||
selection :: Formatter -> Full.Selection -> Lazy.Text
|
||||
selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||
selection formatter = Lazy.Text.append (indentLine formatter')
|
||||
. encodeSelection
|
||||
where
|
||||
encodeSelection (Full.FieldSelection fieldSelection) =
|
||||
field incrementIndent fieldSelection
|
||||
field formatter' fieldSelection
|
||||
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
|
||||
inlineFragment incrementIndent fragmentSelection
|
||||
inlineFragment formatter' fragmentSelection
|
||||
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
|
||||
fragmentSpread incrementIndent fragmentSelection
|
||||
incrementIndent
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
| otherwise = Minified
|
||||
indent'
|
||||
| Pretty indentation <- formatter = indent $ indentation + 1
|
||||
| otherwise = ""
|
||||
fragmentSpread formatter' fragmentSelection
|
||||
formatter' = incrementIndent formatter
|
||||
|
||||
indentLine :: Formatter -> Lazy.Text
|
||||
indentLine formatter
|
||||
| Pretty indentation <- formatter = indent indentation
|
||||
| otherwise = ""
|
||||
|
||||
incrementIndent :: Formatter -> Formatter
|
||||
incrementIndent formatter
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
| otherwise = Minified
|
||||
|
||||
colon :: Formatter -> Lazy.Text
|
||||
colon formatter = eitherFormat formatter ": " ":"
|
||||
@ -197,8 +445,10 @@ directive formatter (Full.Directive name args _)
|
||||
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
|
||||
|
||||
directives :: Formatter -> [Full.Directive] -> Lazy.Text
|
||||
directives Minified = spaces (directive Minified)
|
||||
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
||||
directives Minified values = spaces (directive Minified) values
|
||||
directives formatter values
|
||||
| null values = ""
|
||||
| otherwise = Lazy.Text.cons ' ' $ spaces (directive formatter) values
|
||||
|
||||
-- | Converts a 'Full.Value' into a string.
|
||||
value :: Formatter -> Full.Value -> Lazy.Text
|
||||
@ -294,6 +544,12 @@ nonNullType :: Full.NonNullType -> Lazy.Text
|
||||
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
-- | Produces lowercase operation type: query, mutation or subscription.
|
||||
operationType :: Formatter -> Full.OperationType -> Lazy.Text
|
||||
operationType _formatter Full.Query = "query"
|
||||
operationType _formatter Full.Mutation = "mutation"
|
||||
operationType _formatter Full.Subscription = "subscription"
|
||||
|
||||
-- * Internal
|
||||
|
||||
between :: Char -> Char -> Lazy.Text -> Lazy.Text
|
||||
|
@ -58,6 +58,7 @@ import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Control.Monad (void)
|
||||
|
||||
-- | Standard parser.
|
||||
-- Accepts the type of the parsed token.
|
||||
@ -93,7 +94,7 @@ dollar = symbol "$"
|
||||
|
||||
-- | Parser for "@".
|
||||
at :: Parser ()
|
||||
at = symbol "@" >> pure ()
|
||||
at = void $ symbol "@"
|
||||
|
||||
-- | Parser for "&".
|
||||
amp :: Parser T.Text
|
||||
@ -101,7 +102,7 @@ amp = symbol "&"
|
||||
|
||||
-- | Parser for ":".
|
||||
colon :: Parser ()
|
||||
colon = symbol ":" >> pure ()
|
||||
colon = void $ symbol ":"
|
||||
|
||||
-- | Parser for "=".
|
||||
equals :: Parser T.Text
|
||||
@ -220,7 +221,7 @@ escapeSequence = do
|
||||
|
||||
-- | Parser for the "Byte Order Mark".
|
||||
unicodeBOM :: Parser ()
|
||||
unicodeBOM = optional (char '\xfeff') >> pure ()
|
||||
unicodeBOM = void $ optional $ char '\xfeff'
|
||||
|
||||
-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
|
||||
extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
|
||||
|
@ -450,8 +450,8 @@ value = Full.Variable <$> variable
|
||||
<|> Full.Null <$ nullValue
|
||||
<|> Full.String <$> stringValue
|
||||
<|> Full.Enum <$> try enumValue
|
||||
<|> Full.List <$> brackets (some $ valueNode value)
|
||||
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
|
||||
<|> Full.List <$> brackets (many $ valueNode value)
|
||||
<|> Full.Object <$> braces (many $ objectField $ valueNode value)
|
||||
<?> "Value"
|
||||
|
||||
constValue :: Parser Full.ConstValue
|
||||
|
@ -8,31 +8,22 @@
|
||||
|
||||
-- | Error handling.
|
||||
module Language.GraphQL.Error
|
||||
( CollectErrsT
|
||||
, Error(..)
|
||||
( Error(..)
|
||||
, Path(..)
|
||||
, Resolution(..)
|
||||
, ResolverException(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, parseError
|
||||
, runCollectErrs
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Location(..), Name)
|
||||
import Language.GraphQL.AST (Location(..))
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec
|
||||
( ParseErrorBundle(..)
|
||||
@ -100,57 +91,3 @@ instance Show ResolverException where
|
||||
show (ResolverException e) = show e
|
||||
|
||||
instance Exception ResolverException
|
||||
|
||||
-- * Deprecated
|
||||
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
--
|
||||
-- /runCollectErrs was part of the old executor and isn't used anymore, it will
|
||||
-- be deprecated in the future and removed./
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
=> HashMap Name (Schema.Type m)
|
||||
-> CollectErrsT m a
|
||||
-> m (Response a)
|
||||
runCollectErrs types' res = do
|
||||
(dat, Resolution{..}) <- runStateT res
|
||||
$ Resolution{ errors = Seq.empty, types = types' }
|
||||
pure $ Response dat errors
|
||||
|
||||
-- | Executor context.
|
||||
--
|
||||
-- /Resolution was part of the old executor and isn't used anymore, it will be
|
||||
-- deprecated in the future and removed./
|
||||
data Resolution m = Resolution
|
||||
{ errors :: Seq Error
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
}
|
||||
|
||||
-- | A wrapper to pass error messages around.
|
||||
--
|
||||
-- /CollectErrsT was part of the old executor and isn't used anymore, it will be
|
||||
-- deprecated in the future and removed./
|
||||
type CollectErrsT m = StateT (Resolution m) m
|
||||
|
||||
-- | Adds an error to the list of errors.
|
||||
{-# DEPRECATED #-}
|
||||
addErr :: Monad m => Error -> CollectErrsT m ()
|
||||
addErr v = modify appender
|
||||
where
|
||||
appender :: Monad m => Resolution m -> Resolution m
|
||||
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
|
||||
|
||||
{-# DEPRECATED #-}
|
||||
makeErrorMessage :: Text -> Error
|
||||
makeErrorMessage s = Error s [] []
|
||||
|
||||
-- | Constructs a response object containing only the error with the given
|
||||
-- message.
|
||||
{-# DEPRECATED #-}
|
||||
singleError :: Serialize a => Text -> Response a
|
||||
singleError message = Response null $ Seq.singleton $ Error message [] []
|
||||
|
||||
-- | Convenience function for just wrapping an error message.
|
||||
{-# DEPRECATED #-}
|
||||
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
||||
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
|
||||
|
@ -39,6 +39,7 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Sequence (Seq)
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Typeable (cast)
|
||||
@ -61,6 +62,7 @@ import Language.GraphQL.Error
|
||||
, ResponseEventStream
|
||||
)
|
||||
import Prelude hiding (null)
|
||||
import Language.GraphQL.AST.Document (showVariableName)
|
||||
|
||||
newtype ExecutorT m a = ExecutorT
|
||||
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
|
||||
@ -190,32 +192,42 @@ data QueryError
|
||||
tell :: Monad m => Seq Error -> ExecutorT m ()
|
||||
tell = ExecutorT . lift . Writer.tell
|
||||
|
||||
operationNameErrorText :: Text
|
||||
operationNameErrorText = Text.unlines
|
||||
[ "Named operations must be provided with the name of the desired operation."
|
||||
, "See https://spec.graphql.org/June2018/#sec-Language.Document description."
|
||||
]
|
||||
|
||||
queryError :: QueryError -> Error
|
||||
queryError OperationNameRequired =
|
||||
Error{ message = "Operation name is required.", locations = [], path = [] }
|
||||
let queryErrorMessage = "Operation name is required. " <> operationNameErrorText
|
||||
in Error{ message = queryErrorMessage, locations = [], path = [] }
|
||||
queryError (OperationNotFound operationName) =
|
||||
let queryErrorMessage = Text.concat
|
||||
[ "Operation \""
|
||||
, Text.pack operationName
|
||||
, "\" not found."
|
||||
let queryErrorMessage = Text.unlines
|
||||
[ Text.concat
|
||||
[ "Operation \""
|
||||
, Text.pack operationName
|
||||
, "\" is not found in the named operations you've provided. "
|
||||
]
|
||||
, operationNameErrorText
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [], path = [] }
|
||||
queryError (CoercionError variableDefinition) =
|
||||
let Full.VariableDefinition variableName _ _ location = variableDefinition
|
||||
let (Full.VariableDefinition _ _ _ location) = variableDefinition
|
||||
queryErrorMessage = Text.concat
|
||||
[ "Failed to coerce the variable \""
|
||||
, variableName
|
||||
, "\"."
|
||||
[ "Failed to coerce the variable "
|
||||
, Text.pack $ Full.showVariable variableDefinition
|
||||
, "."
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [location], path = [] }
|
||||
queryError (UnknownInputType variableDefinition) =
|
||||
let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
|
||||
let Full.VariableDefinition _ variableTypeName _ location = variableDefinition
|
||||
queryErrorMessage = Text.concat
|
||||
[ "Variable \""
|
||||
, variableName
|
||||
, "\" has unknown type \""
|
||||
[ "Variable "
|
||||
, Text.pack $ showVariableName variableDefinition
|
||||
, " has unknown type "
|
||||
, Text.pack $ show variableTypeName
|
||||
, "\"."
|
||||
, "."
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [location], path = [] }
|
||||
|
||||
@ -375,6 +387,7 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
|
||||
, Handler (resolverHandler fieldLocation)
|
||||
]
|
||||
where
|
||||
fieldErrorPath = fieldsSegment fields : errorPath
|
||||
inputCoercionHandler :: (MonadCatch m, Serialize a)
|
||||
=> Full.Location
|
||||
-> InputCoercionException
|
||||
@ -402,17 +415,16 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
|
||||
then throwM e
|
||||
else returnError newError
|
||||
exceptionHandler errorLocation e =
|
||||
let newPath = fieldsSegment fields : errorPath
|
||||
newError = constructError e errorLocation newPath
|
||||
let newError = constructError e errorLocation fieldErrorPath
|
||||
in if Out.isNonNullType fieldType
|
||||
then throwM $ FieldException errorLocation newPath e
|
||||
then throwM $ FieldException errorLocation fieldErrorPath e
|
||||
else returnError newError
|
||||
returnError newError = tell (Seq.singleton newError) >> pure null
|
||||
go fieldName inputArguments = do
|
||||
argumentValues <- coerceArgumentValues argumentTypes inputArguments
|
||||
resolvedValue <-
|
||||
resolveFieldValue resolveFunction objectValue fieldName argumentValues
|
||||
completeValue fieldType fields errorPath resolvedValue
|
||||
completeValue fieldType fields fieldErrorPath resolvedValue
|
||||
(resolverField, resolveFunction) = resolverPair
|
||||
Out.Field _ fieldType argumentTypes = resolverField
|
||||
|
||||
@ -445,6 +457,7 @@ resolveAbstractType abstractType values'
|
||||
_ -> pure Nothing
|
||||
| otherwise = pure Nothing
|
||||
|
||||
-- https://spec.graphql.org/October2021/#sec-Value-Completion
|
||||
completeValue :: (MonadCatch m, Serialize a)
|
||||
=> Out.Type m
|
||||
-> NonEmpty (Transform.Field m)
|
||||
@ -454,12 +467,12 @@ completeValue :: (MonadCatch m, Serialize a)
|
||||
completeValue (Out.isNonNullType -> False) _ _ Type.Null =
|
||||
pure null
|
||||
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
|
||||
= foldM go (0, []) list >>= coerceResult outputType . List . snd
|
||||
= foldM go Vector.empty list >>= coerceResult outputType . List . Vector.toList
|
||||
where
|
||||
go (index, accumulator) listItem = do
|
||||
let updatedPath = Index index : errorPath
|
||||
completedValue <- completeValue listType fields updatedPath listItem
|
||||
pure (index + 1, completedValue : accumulator)
|
||||
go accumulator listItem =
|
||||
let updatedPath = Index (Vector.length accumulator) : errorPath
|
||||
in Vector.snoc accumulator
|
||||
<$> completeValue listType fields updatedPath listItem
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
|
||||
coerceResult outputType $ Int int
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
|
||||
@ -476,8 +489,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
|
||||
$ ValueCompletionException (show outputType)
|
||||
$ Type.Enum enum
|
||||
completeValue (Out.ObjectBaseType objectType) fields errorPath result
|
||||
= executeSelectionSet (mergeSelectionSets fields) objectType result
|
||||
$ fieldsSegment fields : errorPath
|
||||
= executeSelectionSet (mergeSelectionSets fields) objectType result errorPath
|
||||
completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = Type.Internal.AbstractInterfaceType interfaceType
|
||||
@ -544,33 +556,24 @@ coerceArgumentValues argumentDefinitions argumentValues =
|
||||
$ Just inputValue
|
||||
| otherwise -> throwM
|
||||
$ InputCoercionException (Text.unpack argumentName) variableType Nothing
|
||||
|
||||
matchFieldValues' = matchFieldValues coerceArgumentValue
|
||||
$ Full.node <$> argumentValues
|
||||
coerceArgumentValue inputType (Transform.Int integer) =
|
||||
coerceInputLiteral inputType (Type.Int integer)
|
||||
coerceArgumentValue inputType (Transform.Boolean boolean) =
|
||||
coerceInputLiteral inputType (Type.Boolean boolean)
|
||||
coerceArgumentValue inputType (Transform.String string) =
|
||||
coerceInputLiteral inputType (Type.String string)
|
||||
coerceArgumentValue inputType (Transform.Float float) =
|
||||
coerceInputLiteral inputType (Type.Float float)
|
||||
coerceArgumentValue inputType (Transform.Enum enum) =
|
||||
coerceInputLiteral inputType (Type.Enum enum)
|
||||
coerceArgumentValue inputType Transform.Null
|
||||
| In.isNonNullType inputType = Nothing
|
||||
| otherwise = coerceInputLiteral inputType Type.Null
|
||||
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
|
||||
let coerceItem = coerceArgumentValue inputType
|
||||
in Type.List <$> traverse coerceItem list
|
||||
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
|
||||
| In.InputObjectType _ _ inputFields <- inputType =
|
||||
let go = forEachField object
|
||||
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
|
||||
in Type.Object <$> resultMap
|
||||
coerceArgumentValue _ (Transform.Variable variable) = pure variable
|
||||
coerceArgumentValue _ _ = Nothing
|
||||
forEachField object variableName (In.InputField _ variableType defaultValue) =
|
||||
matchFieldValues coerceArgumentValue object variableName variableType defaultValue
|
||||
|
||||
coerceArgumentValue inputType transform =
|
||||
coerceInputLiteral inputType $ extractArgumentValue transform
|
||||
|
||||
extractArgumentValue (Transform.Int integer) = Type.Int integer
|
||||
extractArgumentValue (Transform.Boolean boolean) = Type.Boolean boolean
|
||||
extractArgumentValue (Transform.String string) = Type.String string
|
||||
extractArgumentValue (Transform.Float float) = Type.Float float
|
||||
extractArgumentValue (Transform.Enum enum) = Type.Enum enum
|
||||
extractArgumentValue Transform.Null = Type.Null
|
||||
extractArgumentValue (Transform.List list) =
|
||||
Type.List $ extractArgumentValue <$> list
|
||||
extractArgumentValue (Transform.Object object) =
|
||||
Type.Object $ extractArgumentValue <$> object
|
||||
extractArgumentValue (Transform.Variable variable) = variable
|
||||
|
||||
collectFields :: Monad m
|
||||
=> Out.ObjectType m
|
||||
|
@ -5,7 +5,6 @@
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | Types and functions used for input and result coercion.
|
||||
module Language.GraphQL.Execute.Coerce
|
||||
@ -16,10 +15,6 @@ module Language.GraphQL.Execute.Coerce
|
||||
, matchFieldValues
|
||||
) where
|
||||
|
||||
#ifdef WITH_JSON
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Scientific (toBoundedInteger, toRealFloat)
|
||||
#endif
|
||||
import Data.Int (Int32)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
@ -227,69 +222,3 @@ instance Serialize Type.Value where
|
||||
$ HashMap.fromList
|
||||
$ OrderedMap.toList object
|
||||
serialize _ _ = Nothing
|
||||
|
||||
#ifdef WITH_JSON
|
||||
instance Serialize Aeson.Value where
|
||||
serialize (Out.ScalarBaseType scalarType) value
|
||||
| Type.ScalarType "Int" _ <- scalarType
|
||||
, Int int <- value = Just $ Aeson.toJSON int
|
||||
| Type.ScalarType "Float" _ <- scalarType
|
||||
, Float float <- value = Just $ Aeson.toJSON float
|
||||
| Type.ScalarType "String" _ <- scalarType
|
||||
, String string <- value = Just $ Aeson.String string
|
||||
| Type.ScalarType "ID" _ <- scalarType
|
||||
, String string <- value = Just $ Aeson.String string
|
||||
| Type.ScalarType "Boolean" _ <- scalarType
|
||||
, Boolean boolean <- value = Just $ Aeson.Bool boolean
|
||||
serialize _ (Enum enum) = Just $ Aeson.String enum
|
||||
serialize _ (List list) = Just $ Aeson.toJSON list
|
||||
serialize _ (Object object) = Just
|
||||
$ Aeson.object
|
||||
$ OrderedMap.toList
|
||||
$ Aeson.toJSON <$> object
|
||||
serialize _ _ = Nothing
|
||||
null = Aeson.Null
|
||||
|
||||
instance VariableValue Aeson.Value where
|
||||
coerceVariableValue _ Aeson.Null = Just Type.Null
|
||||
coerceVariableValue (In.ScalarBaseType scalarType) value
|
||||
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
|
||||
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
|
||||
| (Aeson.Number numberValue) <- value
|
||||
, (Type.ScalarType "Float" _) <- scalarType =
|
||||
Just $ Type.Float $ toRealFloat numberValue
|
||||
| (Aeson.Number numberValue) <- value = -- ID or Int
|
||||
Type.Int <$> toBoundedInteger numberValue
|
||||
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
|
||||
Just $ Type.Enum stringValue
|
||||
coerceVariableValue (In.InputObjectBaseType objectType) value
|
||||
| (Aeson.Object objectValue) <- value = do
|
||||
let (In.InputObjectType _ _ inputFields) = objectType
|
||||
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
|
||||
if HashMap.null newObjectValue
|
||||
then Just $ Type.Object resultMap
|
||||
else Nothing
|
||||
where
|
||||
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
|
||||
$ Just (objectValue, HashMap.empty)
|
||||
matchFieldValues' _ _ Nothing = Nothing
|
||||
matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
|
||||
let (In.InputField _ fieldType _) = inputField
|
||||
insert = flip (HashMap.insert fieldName) resultMap
|
||||
newObjectValue = HashMap.delete fieldName objectValue
|
||||
in case HashMap.lookup fieldName objectValue of
|
||||
Just variableValue -> do
|
||||
coerced <- coerceVariableValue fieldType variableValue
|
||||
pure (newObjectValue, insert coerced)
|
||||
Nothing -> Just (objectValue, resultMap)
|
||||
coerceVariableValue (In.ListBaseType listType) value
|
||||
| (Aeson.Array arrayValue) <- value =
|
||||
Type.List <$> foldr foldVector (Just []) arrayValue
|
||||
| otherwise = coerceVariableValue listType value
|
||||
where
|
||||
foldVector _ Nothing = Nothing
|
||||
foldVector variableValue (Just list) = do
|
||||
coerced <- coerceVariableValue listType variableValue
|
||||
pure $ coerced : list
|
||||
coerceVariableValue _ _ = Nothing
|
||||
#endif
|
||||
|
@ -21,7 +21,7 @@ stripIndentation code = reverse
|
||||
indent count (' ' : xs) = indent (count - 1) xs
|
||||
indent _ xs = xs
|
||||
withoutLeadingNewlines = dropNewlines code
|
||||
dropNewlines = dropWhile (== '\n')
|
||||
dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==)
|
||||
spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
|
||||
|
||||
-- | Removes leading and trailing newlines. Indentation of the first line is
|
||||
|
@ -18,6 +18,8 @@ module Language.GraphQL.Type.Definition
|
||||
, float
|
||||
, id
|
||||
, int
|
||||
, showNonNullType
|
||||
, showNonNullListType
|
||||
, selection
|
||||
, string
|
||||
) where
|
||||
@ -207,3 +209,11 @@ include = handle include'
|
||||
(Just (Boolean True)) -> Include directive'
|
||||
_ -> Skip
|
||||
include' directive' = Continue directive'
|
||||
|
||||
showNonNullType :: Show a => a -> String
|
||||
showNonNullType = (++ "!") . show
|
||||
|
||||
showNonNullListType :: Show a => a -> String
|
||||
showNonNullListType listType =
|
||||
let representation = show listType
|
||||
in concat ["[", representation, "]!"]
|
||||
|
@ -66,10 +66,11 @@ instance Show Type where
|
||||
show (NamedEnumType enumType) = show enumType
|
||||
show (NamedInputObjectType inputObjectType) = show inputObjectType
|
||||
show (ListType baseType) = concat ["[", show baseType, "]"]
|
||||
show (NonNullScalarType scalarType) = '!' : show scalarType
|
||||
show (NonNullEnumType enumType) = '!' : show enumType
|
||||
show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType
|
||||
show (NonNullListType baseType) = concat ["![", show baseType, "]"]
|
||||
show (NonNullScalarType scalarType) = Definition.showNonNullType scalarType
|
||||
show (NonNullEnumType enumType) = Definition.showNonNullType enumType
|
||||
show (NonNullInputObjectType inputObjectType) =
|
||||
Definition.showNonNullType inputObjectType
|
||||
show (NonNullListType baseType) = Definition.showNonNullListType baseType
|
||||
|
||||
-- | Field argument definition.
|
||||
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
||||
|
@ -115,12 +115,12 @@ instance forall a. Show (Type a) where
|
||||
show (NamedInterfaceType interfaceType) = show interfaceType
|
||||
show (NamedUnionType unionType) = show unionType
|
||||
show (ListType baseType) = concat ["[", show baseType, "]"]
|
||||
show (NonNullScalarType scalarType) = '!' : show scalarType
|
||||
show (NonNullEnumType enumType) = '!' : show enumType
|
||||
show (NonNullObjectType inputObjectType) = '!' : show inputObjectType
|
||||
show (NonNullInterfaceType interfaceType) = '!' : show interfaceType
|
||||
show (NonNullUnionType unionType) = '!' : show unionType
|
||||
show (NonNullListType baseType) = concat ["![", show baseType, "]"]
|
||||
show (NonNullScalarType scalarType) = showNonNullType scalarType
|
||||
show (NonNullEnumType enumType) = showNonNullType enumType
|
||||
show (NonNullObjectType inputObjectType) = showNonNullType inputObjectType
|
||||
show (NonNullInterfaceType interfaceType) = showNonNullType interfaceType
|
||||
show (NonNullUnionType unionType) = showNonNullType unionType
|
||||
show (NonNullListType baseType) = showNonNullListType baseType
|
||||
|
||||
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||
pattern ScalarBaseType :: forall m. ScalarType -> Type m
|
||||
|
@ -2,11 +2,13 @@
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- | This module contains default rules defined in the GraphQL specification.
|
||||
@ -54,13 +56,14 @@ import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (groupBy, sortBy, sortOn)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import GHC.Records (HasField(..))
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.Internal as Type
|
||||
@ -618,6 +621,10 @@ noUndefinedVariablesRule =
|
||||
, "\"."
|
||||
]
|
||||
|
||||
-- Used to find the difference between defined and used variables. The first
|
||||
-- argument are variables defined in the operation, the second argument are
|
||||
-- variables used in the query. It should return the difference between these
|
||||
-- 2 sets.
|
||||
type UsageDifference
|
||||
= HashMap Full.Name [Full.Location]
|
||||
-> HashMap Full.Name [Full.Location]
|
||||
@ -664,11 +671,17 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
|
||||
= filterSelections' selections
|
||||
>>= lift . mapReaderT (<> mapDirectives directives') . pure
|
||||
findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
|
||||
mapArguments = Seq.fromList . mapMaybe findArgumentVariables
|
||||
mapArguments = Seq.fromList . (>>= findArgumentVariables)
|
||||
mapDirectives = foldMap findDirectiveVariables
|
||||
findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
|
||||
Just (value', [location])
|
||||
findArgumentVariables _ = Nothing
|
||||
|
||||
findArgumentVariables (Full.Argument _ value _) = findNodeVariables value
|
||||
findNodeVariables Full.Node{ node = value, ..} = findValueVariables location value
|
||||
|
||||
findValueVariables location (Full.Variable value') = [(value', [location])]
|
||||
findValueVariables _ (Full.List values) = values >>= findNodeVariables
|
||||
findValueVariables _ (Full.Object fields) = fields
|
||||
>>= findNodeVariables . getField @"value"
|
||||
findValueVariables _ _ = []
|
||||
makeError operationName (variableName, locations') = Error
|
||||
{ message = errorMessage operationName variableName
|
||||
, locations = locations'
|
||||
@ -1551,9 +1564,9 @@ valuesOfCorrectTypeRule = ValueRule go constGo
|
||||
toConst Full.Null = Just Full.ConstNull
|
||||
toConst (Full.Enum enum) = Just $ Full.ConstEnum enum
|
||||
toConst (Full.List values) =
|
||||
Just $ Full.ConstList $ catMaybes $ toConstNode <$> values
|
||||
Just $ Full.ConstList $ mapMaybe toConstNode values
|
||||
toConst (Full.Object fields) = Just $ Full.ConstObject
|
||||
$ catMaybes $ constObjectField <$> fields
|
||||
$ mapMaybe constObjectField fields
|
||||
constObjectField Full.ObjectField{..}
|
||||
| Just constValue <- toConstNode value =
|
||||
Just $ Full.ObjectField name constValue location
|
||||
|
@ -1,49 +0,0 @@
|
||||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
#ifdef WITH_JSON
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Test helpers.
|
||||
module Test.Hspec.GraphQL
|
||||
( shouldResolve
|
||||
, shouldResolveTo
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.Error
|
||||
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
|
||||
|
||||
-- | Asserts that a query resolves to some value.
|
||||
shouldResolveTo :: MonadCatch m
|
||||
=> Either (ResponseEventStream m Aeson.Value) Aeson.Object
|
||||
-> Aeson.Object
|
||||
-> Expectation
|
||||
shouldResolveTo (Right actual) expected = actual `shouldBe` expected
|
||||
shouldResolveTo _ _ = expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
|
||||
-- | Asserts that the response doesn't contain any errors.
|
||||
shouldResolve :: MonadCatch m
|
||||
=> (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object))
|
||||
-> Text
|
||||
-> Expectation
|
||||
shouldResolve executor query = do
|
||||
actual <- executor query
|
||||
case actual of
|
||||
Right response ->
|
||||
response `shouldNotSatisfy` HashMap.member "errors"
|
||||
_ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
#else
|
||||
module Test.Hspec.GraphQL
|
||||
(
|
||||
) where
|
||||
#endif
|
102
tests/Language/GraphQL/AST/Arbitrary.hs
Normal file
102
tests/Language/GraphQL/AST/Arbitrary.hs
Normal file
@ -0,0 +1,102 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Language.GraphQL.AST.Arbitrary where
|
||||
|
||||
import qualified Language.GraphQL.AST.Document as Doc
|
||||
import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
|
||||
import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..))
|
||||
import Test.QuickCheck.Gen (Gen (..))
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Functor ((<&>))
|
||||
|
||||
newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
|
||||
|
||||
alpha :: String
|
||||
alpha = ['a'..'z'] <> ['A'..'Z']
|
||||
|
||||
num :: String
|
||||
num = ['0'..'9']
|
||||
|
||||
instance Arbitrary AnyPrintableChar where
|
||||
arbitrary = AnyPrintableChar <$> elements chars
|
||||
where
|
||||
chars = alpha <> num <> ['_']
|
||||
|
||||
newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyPrintableText where
|
||||
arbitrary = do
|
||||
nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar))
|
||||
pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr)
|
||||
|
||||
-- https://spec.graphql.org/June2018/#Name
|
||||
newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyName where
|
||||
arbitrary = do
|
||||
firstChar <- elements $ alpha <> ['_']
|
||||
rest <- (arbitrary :: Gen [AnyPrintableChar])
|
||||
pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest)
|
||||
|
||||
newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyLocation where
|
||||
arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary)
|
||||
|
||||
newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyNode a) where
|
||||
arbitrary = do
|
||||
(AnyLocation location') <- arbitrary
|
||||
node' <- flip Doc.Node location' <$> arbitrary
|
||||
pure $ AnyNode node'
|
||||
|
||||
newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyObjectField a) where
|
||||
arbitrary = do
|
||||
name' <- getAnyName <$> arbitrary
|
||||
value' <- getAnyNode <$> arbitrary
|
||||
location' <- getAnyLocation <$> arbitrary
|
||||
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
|
||||
|
||||
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value }
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyValue
|
||||
where
|
||||
arbitrary =
|
||||
let variableGen :: Gen Doc.Value
|
||||
variableGen = Doc.Variable . getAnyName <$> arbitrary
|
||||
listGen :: Gen [Doc.Node Doc.Value]
|
||||
listGen = (resize 5 . listOf) nodeGen
|
||||
nodeGen :: Gen (Doc.Node Doc.Value)
|
||||
nodeGen = fmap getAnyNode arbitrary <&> fmap getAnyValue
|
||||
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
||||
objectGen = resize 1
|
||||
$ fmap getNonEmpty arbitrary
|
||||
<&> map (fmap getAnyValue . getAnyObjectField)
|
||||
in AnyValue <$> oneof
|
||||
[ variableGen
|
||||
, Doc.Int <$> arbitrary
|
||||
, Doc.Float <$> arbitrary
|
||||
, Doc.String . getAnyPrintableText <$> arbitrary
|
||||
, Doc.Boolean <$> arbitrary
|
||||
, MkGen $ \_ _ -> Doc.Null
|
||||
, Doc.Enum . getAnyName <$> arbitrary
|
||||
, Doc.List <$> listGen
|
||||
, Doc.Object <$> objectGen
|
||||
]
|
||||
|
||||
newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument }
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyArgument a) where
|
||||
arbitrary = do
|
||||
name' <- getAnyName <$> arbitrary
|
||||
(AnyValue value') <- arbitrary
|
||||
(AnyLocation location') <- arbitrary
|
||||
pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location'
|
||||
|
||||
printArgument :: AnyArgument AnyValue -> Text
|
||||
printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value'
|
@ -18,3 +18,9 @@ spec = do
|
||||
]
|
||||
expected = "{ field1: 1.2, field2: null }"
|
||||
in show object `shouldBe` expected
|
||||
|
||||
describe "Description" $
|
||||
it "keeps content when merging with no description" $
|
||||
let expected = Description $ Just "Left description"
|
||||
actual = expected <> Description Nothing
|
||||
in actual `shouldBe` expected
|
||||
|
@ -4,6 +4,7 @@ module Language.GraphQL.AST.EncoderSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.AST.Encoder
|
||||
import Language.GraphQL.TH
|
||||
@ -173,3 +174,96 @@ spec = do
|
||||
|] '\n'
|
||||
actual = definition pretty operation
|
||||
in actual `shouldBe` expected
|
||||
|
||||
describe "operationType" $
|
||||
it "produces lowercase mutation operation type" $
|
||||
let actual = operationType pretty Full.Mutation
|
||||
in actual `shouldBe` "mutation"
|
||||
|
||||
describe "typeSystemDefinition" $ do
|
||||
it "produces a schema with an indented operation type definition" $
|
||||
let queryType = Full.OperationTypeDefinition Full.Query "QueryRootType"
|
||||
mutationType = Full.OperationTypeDefinition Full.Mutation "MutationType"
|
||||
operations = queryType :| pure mutationType
|
||||
definition' = Full.SchemaDefinition [] operations
|
||||
expected = Text.Lazy.snoc [gql|
|
||||
schema {
|
||||
query: QueryRootType
|
||||
mutation: MutationType
|
||||
}
|
||||
|] '\n'
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes a scalar type definition" $
|
||||
let uuidType = Full.ScalarTypeDefinition mempty "UUID" mempty
|
||||
definition' = Full.TypeDefinition uuidType
|
||||
expected = "scalar UUID"
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an interface definition" $
|
||||
let someType = Full.TypeNamed "String"
|
||||
argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
|
||||
arguments = Full.ArgumentsDefinition [argument]
|
||||
definition' = Full.TypeDefinition
|
||||
$ Full.InterfaceTypeDefinition mempty "UUID" mempty
|
||||
$ pure
|
||||
$ Full.FieldDefinition mempty "value" arguments someType mempty
|
||||
expected = [gql|
|
||||
interface UUID {
|
||||
value(arg: String): String
|
||||
}
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an union definition" $
|
||||
let definition' = Full.TypeDefinition
|
||||
$ Full.UnionTypeDefinition mempty "SearchResult" mempty
|
||||
$ Full.UnionMemberTypes ["Photo", "Person"]
|
||||
expected = [gql|
|
||||
union SearchResult =
|
||||
| Photo
|
||||
| Person
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an enum definition" $
|
||||
let values =
|
||||
[ Full.EnumValueDefinition mempty "NORTH" mempty
|
||||
, Full.EnumValueDefinition mempty "EAST" mempty
|
||||
, Full.EnumValueDefinition mempty "SOUTH" mempty
|
||||
, Full.EnumValueDefinition mempty "WEST" mempty
|
||||
]
|
||||
definition' = Full.TypeDefinition
|
||||
$ Full.EnumTypeDefinition mempty "Direction" mempty values
|
||||
expected = [gql|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes an input type" $
|
||||
let intType = Full.TypeNonNull $ Full.NonNullTypeNamed "Int"
|
||||
stringType = Full.TypeNamed "String"
|
||||
fields =
|
||||
[ Full.InputValueDefinition mempty "a" stringType Nothing mempty
|
||||
, Full.InputValueDefinition mempty "b" intType Nothing mempty
|
||||
]
|
||||
definition' = Full.TypeDefinition
|
||||
$ Full.InputObjectTypeDefinition mempty "ExampleInputObject" mempty fields
|
||||
expected = [gql|
|
||||
input ExampleInputObject {
|
||||
a: String
|
||||
b: Int!
|
||||
}
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
@ -5,46 +5,78 @@ module Language.GraphQL.AST.ParserSpec
|
||||
) where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec (Spec, describe, it, context)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
import Text.Megaparsec (parse)
|
||||
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
|
||||
import Language.GraphQL.AST.Arbitrary
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Parser" $ do
|
||||
it "accepts BOM header" $
|
||||
parse document "" `shouldSucceedOn` "\xfeff{foo}"
|
||||
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: """Argument""")
|
||||
}|]
|
||||
context "Arguments" $ do
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: """Argument""")
|
||||
}|]
|
||||
|
||||
it "accepts strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: "Argument")
|
||||
}|]
|
||||
it "accepts strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: "Argument")
|
||||
}|]
|
||||
|
||||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth($username: String!, $password: String!){
|
||||
test
|
||||
}|]
|
||||
it "accepts int as argument1" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
user(id: 4)
|
||||
}|]
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: "username", password: "password")
|
||||
}|]
|
||||
it "accepts boolean as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(flag: true) { field1 }
|
||||
}|]
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
it "accepts float as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
body(height: 172.5) { height }
|
||||
}|]
|
||||
|
||||
it "accepts empty list as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
query(list: []) { field1 }
|
||||
}|]
|
||||
|
||||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth($username: String!, $password: String!){
|
||||
test
|
||||
}|]
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: "username", password: "password")
|
||||
}|]
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
|
||||
it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
|
||||
let
|
||||
query' :: Text
|
||||
arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
|
||||
query' = "query(" <> Text.intercalate ", " arguments <> ")" in
|
||||
parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
|
||||
|
||||
it "parses minimal schema definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]
|
||||
@ -95,16 +127,6 @@ spec = describe "Parser" $ do
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal enum type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal input object type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
input Point2D {
|
||||
@ -202,6 +224,13 @@ spec = describe "Parser" $ do
|
||||
}
|
||||
|]
|
||||
|
||||
it "rejects empty selection set" $
|
||||
parse document "" `shouldFailOn` [gql|
|
||||
query {
|
||||
innerField {}
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses documents beginning with a comment" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
"""
|
||||
|
@ -2,13 +2,18 @@
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Language.GraphQL.ExecuteSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Data.Conduit
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
@ -20,12 +25,23 @@ import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute (execute)
|
||||
import Language.GraphQL.TH
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Prelude hiding (id)
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.Megaparsec (parse, errorBundlePretty)
|
||||
import Schemas.HeroSchema (heroSchema)
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Test.Hspec.Expectations
|
||||
( Expectation
|
||||
, expectationFailure
|
||||
)
|
||||
import Data.Either (fromRight)
|
||||
|
||||
data PhilosopherException = PhilosopherException
|
||||
deriving Show
|
||||
@ -36,7 +52,7 @@ instance Exception PhilosopherException where
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
philosopherSchema :: Schema (Either SomeException)
|
||||
philosopherSchema :: Schema IO
|
||||
philosopherSchema =
|
||||
schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
|
||||
where
|
||||
@ -46,12 +62,14 @@ philosopherSchema =
|
||||
, Schema.ObjectType bookCollectionType
|
||||
]
|
||||
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
queryType :: Out.ObjectType IO
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("philosopher", ValueResolver philosopherField philosopherResolver)
|
||||
, ("genres", ValueResolver genresField genresResolver)
|
||||
, ("throwing", ValueResolver throwingField throwingResolver)
|
||||
, ("count", ValueResolver countField countResolver)
|
||||
, ("sequence", ValueResolver sequenceField sequenceResolver)
|
||||
, ("withInputObject", ValueResolver withInputObjectField withInputObjectResolver)
|
||||
]
|
||||
where
|
||||
philosopherField =
|
||||
@ -59,17 +77,35 @@ queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NamedScalarType id) Nothing
|
||||
philosopherResolver = pure $ Object mempty
|
||||
genresField =
|
||||
throwingField =
|
||||
let fieldType = Out.ListType $ Out.NonNullScalarType string
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
genresResolver :: Resolve (Either SomeException)
|
||||
genresResolver = throwM PhilosopherException
|
||||
throwingResolver :: Resolve IO
|
||||
throwingResolver = throwM PhilosopherException
|
||||
countField =
|
||||
let fieldType = Out.NonNullScalarType int
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
countResolver = pure ""
|
||||
sequenceField =
|
||||
let fieldType = Out.ListType $ Out.NonNullScalarType int
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
sequenceResolver = pure intSequence
|
||||
withInputObjectResolver = pure $ Type.Int 0
|
||||
withInputObjectField =
|
||||
Out.Field Nothing (Out.NonNullScalarType int) $ HashMap.fromList
|
||||
[("values", In.Argument Nothing withInputObjectArgumentType Nothing)]
|
||||
withInputObjectArgumentType = In.NonNullListType
|
||||
$ In.NonNullInputObjectType inputObjectType
|
||||
|
||||
musicType :: Out.ObjectType (Either SomeException)
|
||||
inputObjectType :: In.InputObjectType
|
||||
inputObjectType = In.InputObjectType "InputObject" Nothing $
|
||||
HashMap.singleton "name" $
|
||||
In.InputField Nothing (In.NonNullScalarType int) Nothing
|
||||
|
||||
intSequence :: Value
|
||||
intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3]
|
||||
|
||||
musicType :: Out.ObjectType IO
|
||||
musicType = Out.ObjectType "Music" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -79,7 +115,7 @@ musicType = Out.ObjectType "Music" Nothing []
|
||||
instrumentResolver = pure $ String "piano"
|
||||
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
poetryType :: Out.ObjectType (Either SomeException)
|
||||
poetryType :: Out.ObjectType IO
|
||||
poetryType = Out.ObjectType "Poetry" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -89,10 +125,10 @@ poetryType = Out.ObjectType "Poetry" Nothing []
|
||||
genreResolver = pure $ String "Futurism"
|
||||
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
interestType :: Out.UnionType (Either SomeException)
|
||||
interestType :: Out.UnionType IO
|
||||
interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
|
||||
|
||||
philosopherType :: Out.ObjectType (Either SomeException)
|
||||
philosopherType :: Out.ObjectType IO
|
||||
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -133,14 +169,14 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
firstLanguageResolver = pure Null
|
||||
|
||||
workType :: Out.InterfaceType (Either SomeException)
|
||||
workType :: Out.InterfaceType IO
|
||||
workType = Out.InterfaceType "Work" Nothing []
|
||||
$ HashMap.fromList fields
|
||||
where
|
||||
fields = [("title", titleField)]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
bookType :: Out.ObjectType (Either SomeException)
|
||||
bookType :: Out.ObjectType IO
|
||||
bookType = Out.ObjectType "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -150,7 +186,7 @@ bookType = Out.ObjectType "Book" Nothing [workType]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen"
|
||||
|
||||
bookCollectionType :: Out.ObjectType (Either SomeException)
|
||||
bookCollectionType :: Out.ObjectType IO
|
||||
bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
@ -160,7 +196,7 @@ bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "The Three Critiques"
|
||||
|
||||
subscriptionType :: Out.ObjectType (Either SomeException)
|
||||
subscriptionType :: Out.ObjectType IO
|
||||
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ EventStreamResolver quoteField (pure $ Object mempty)
|
||||
@ -169,7 +205,7 @@ subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
||||
|
||||
quoteType :: Out.ObjectType (Either SomeException)
|
||||
quoteType :: Out.ObjectType IO
|
||||
quoteType = Out.ObjectType "Quote" Nothing []
|
||||
$ HashMap.singleton "quote"
|
||||
$ ValueResolver quoteField
|
||||
@ -178,7 +214,7 @@ quoteType = Out.ObjectType "Quote" Nothing []
|
||||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
schoolType :: EnumType
|
||||
schoolType :: Type.EnumType
|
||||
schoolType = EnumType "School" Nothing $ HashMap.fromList
|
||||
[ ("NOMINALISM", EnumValue Nothing)
|
||||
, ("REALISM", EnumValue Nothing)
|
||||
@ -186,12 +222,48 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
|
||||
]
|
||||
|
||||
type EitherStreamOrValue = Either
|
||||
(ResponseEventStream (Either SomeException) Value)
|
||||
(Response Value)
|
||||
(ResponseEventStream IO Type.Value)
|
||||
(Response Type.Value)
|
||||
|
||||
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute' =
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Value)
|
||||
-- Asserts that a query resolves to a value.
|
||||
shouldResolveTo :: Text.Text -> Response Type.Value -> Expectation
|
||||
shouldResolveTo querySource expected =
|
||||
case parse document "" querySource of
|
||||
(Right parsedDocument) ->
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) parsedDocument >>= go
|
||||
(Left errorBundle) -> expectationFailure $ errorBundlePretty errorBundle
|
||||
where
|
||||
go = \case
|
||||
Right result -> shouldBe result expected
|
||||
Left _ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
|
||||
-- Asserts that the executor produces an error that starts with a string.
|
||||
shouldContainError :: Either (ResponseEventStream IO Type.Value) (Response Type.Value)
|
||||
-> Text
|
||||
-> Expectation
|
||||
shouldContainError streamOrValue expected =
|
||||
case streamOrValue of
|
||||
Right response -> respond response
|
||||
Left _ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
where
|
||||
startsWith :: Text.Text -> Text.Text -> Bool
|
||||
startsWith xs ys = Text.take (Text.length ys) xs == ys
|
||||
respond :: Response Type.Value -> Expectation
|
||||
respond Response{ errors }
|
||||
| any ((`startsWith` expected) . message) errors = pure ()
|
||||
| otherwise = expectationFailure
|
||||
"the query is expected to execute with errors, but the response doesn't contain any errors"
|
||||
|
||||
parseAndExecute :: Schema IO
|
||||
-> Maybe Text
|
||||
-> HashMap Name Type.Value
|
||||
-> Text
|
||||
-> IO (Either (ResponseEventStream IO Type.Value) (Response Type.Value))
|
||||
parseAndExecute schema' operation variables
|
||||
= either (pure . parseError) (execute schema' operation variables)
|
||||
. parse document ""
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
@ -207,9 +279,7 @@ spec =
|
||||
}
|
||||
|]
|
||||
expected = Response (Object mempty) mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" sourceQuery
|
||||
in actual `shouldBe` expected
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Query" $ do
|
||||
it "skips unknown fields" $
|
||||
@ -219,9 +289,8 @@ spec =
|
||||
$ HashMap.singleton "firstName"
|
||||
$ String "Friedrich"
|
||||
expected = Response data'' mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName surname } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { firstName surname } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
it "merges selections" $
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "philosopher"
|
||||
@ -231,119 +300,174 @@ spec =
|
||||
, ("lastName", String "Nietzsche")
|
||||
]
|
||||
expected = Response data'' mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "errors on invalid output enum values" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Value completion error. Expected type !School, found: EXISTENTIALISM."
|
||||
"Value completion error. Expected type School!, found: EXISTENTIALISM."
|
||||
, locations = [Location 1 17]
|
||||
, path = [Segment "philosopher", Segment "school"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { school } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { school } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for non-null unions" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Value completion error. Expected type !Interest, found: { instrument: \"piano\" }."
|
||||
"Value completion error. Expected type Interest!, found: { instrument: \"piano\" }."
|
||||
, locations = [Location 1 17]
|
||||
, path = [Segment "philosopher", Segment "interest"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { interest } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { interest } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for invalid interfaces" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message
|
||||
= "Value completion error. Expected type !Work, found:\
|
||||
= "Value completion error. Expected type Work!, found:\
|
||||
\ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }."
|
||||
, locations = [Location 1 17]
|
||||
, path = [Segment "philosopher", Segment "majorWork"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { majorWork { title } } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "gives location information for invalid scalar arguments" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Argument \"id\" has invalid type. Expected type ID, found: True."
|
||||
, locations = [Location 1 15]
|
||||
, path = [Segment "philosopher"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: true) { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { majorWork { title } } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Unable to coerce result to !Int."
|
||||
{ message = "Unable to coerce result to Int!."
|
||||
, locations = [Location 1 26]
|
||||
, path = [Segment "philosopher", Segment "century"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { century } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: \"1\") { century } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Object $ HashMap.singleton "genres" Null
|
||||
let data'' = Object $ HashMap.singleton "throwing" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "PhilosopherException"
|
||||
, locations = [Location 1 3]
|
||||
, path = [Segment "genres"]
|
||||
, path = [Segment "throwing"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ genres }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ throwing }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "sets data to null if a root field isn't nullable" $
|
||||
let executionErrors = pure $ Error
|
||||
{ message = "Unable to coerce result to !Int."
|
||||
{ message = "Unable to coerce result to Int!."
|
||||
, locations = [Location 1 3]
|
||||
, path = [Segment "count"]
|
||||
}
|
||||
expected = Response Null executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ count }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ count }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "detects nullability errors" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Value completion error. Expected type !String, found: null."
|
||||
{ message = "Value completion error. Expected type String!, found: null."
|
||||
, locations = [Location 1 26]
|
||||
, path = [Segment "philosopher", Segment "firstLanguage"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "returns list elements in the original order" $
|
||||
let data'' = Object $ HashMap.singleton "sequence" intSequence
|
||||
expected = Response data'' mempty
|
||||
sourceQuery = "{ sequence }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Arguments" $ do
|
||||
it "gives location information for invalid scalar arguments" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
executionErrors = pure $ Error
|
||||
{ message =
|
||||
"Argument \"id\" has invalid type. Expected type ID, found: True."
|
||||
, locations = [Location 1 15]
|
||||
, path = [Segment "philosopher"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
sourceQuery = "{ philosopher(id: true) { lastName } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "puts an object in a list if needed" $
|
||||
let data'' = Object $ HashMap.singleton "withInputObject" $ Type.Int 0
|
||||
expected = Response data'' mempty
|
||||
sourceQuery = "{ withInputObject(values: { name: 0 }) }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "queryError" $ do
|
||||
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
|
||||
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
|
||||
|
||||
it "throws operation name is required error" $ do
|
||||
let expectedErrorMessage = "Operation name is required"
|
||||
actual <- parseAndExecute philosopherSchema Nothing mempty twoQueries
|
||||
actual `shouldContainError` expectedErrorMessage
|
||||
|
||||
it "throws operation not found error" $ do
|
||||
let expectedErrorMessage = "Operation \"C\" is not found"
|
||||
actual <- parseAndExecute philosopherSchema (Just "C") mempty twoQueries
|
||||
actual `shouldContainError` expectedErrorMessage
|
||||
|
||||
it "throws variable coercion error" $ do
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Failed to coerce the variable $id: String."
|
||||
, locations =[Location 1 7]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
|
||||
Right actual <- either (pure . parseError) executeWithVars
|
||||
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
actual `shouldBe` expected
|
||||
|
||||
it "throws variable unkown input type error" $
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Variable $id has unknown type Cat."
|
||||
, locations =[Location 1 7]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
sourceQuery = "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Error path" $ do
|
||||
let executeHero :: Document -> IO EitherStreamOrValue
|
||||
executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Type.Value)
|
||||
|
||||
it "at the beggining of the list" $ do
|
||||
Right actual <- either (pure . parseError) executeHero
|
||||
$ parse document "" "{ hero(id: \"1\") { friends { name } } }"
|
||||
let Response _ errors' = actual
|
||||
Error _ _ path' = fromJust $ Seq.lookup 0 errors'
|
||||
expected = [Segment "hero", Segment "friends", Index 0, Segment "name"]
|
||||
in path' `shouldBe` expected
|
||||
|
||||
context "Subscription" $
|
||||
it "subscribes" $
|
||||
it "subscribes" $ do
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ Object
|
||||
$ HashMap.singleton "quote"
|
||||
$ String "Naturam expelles furca, tamen usque recurret."
|
||||
expected = Response data'' mempty
|
||||
Right (Left stream) = either (pure . parseError) execute'
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Right (Just actual) = runConduit $ stream .| await
|
||||
in actual `shouldBe` expected
|
||||
Left stream <- execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
|
||||
$ fromRight (error "Parse error")
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Just actual <- runConduit $ stream .| await
|
||||
actual `shouldBe` expected
|
||||
|
@ -29,6 +29,7 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("dog", dogResolver)
|
||||
, ("cat", catResolver)
|
||||
, ("findDog", findDogResolver)
|
||||
, ("findCats", findCatsResolver)
|
||||
]
|
||||
where
|
||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||
@ -39,6 +40,11 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
findDogResolver = ValueResolver findDogField $ pure Null
|
||||
catField = Field Nothing (Out.NamedObjectType catType) mempty
|
||||
catResolver = ValueResolver catField $ pure Null
|
||||
findCatsArguments = HashMap.singleton "commands"
|
||||
$ In.Argument Nothing (In.NonNullListType $ In.NonNullEnumType catCommandType)
|
||||
$ Just $ List []
|
||||
findCatsField = Field Nothing (Out.NonNullListType $ Out.NonNullObjectType catType) findCatsArguments
|
||||
findCatsResolver = ValueResolver findCatsField $ pure $ List []
|
||||
|
||||
catCommandType :: EnumType
|
||||
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
|
||||
@ -538,7 +544,7 @@ spec =
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
context "noUndefinedVariablesRule" $
|
||||
context "noUndefinedVariablesRule" $ do
|
||||
it "rejects undefined variables" $
|
||||
let queryString = [gql|
|
||||
query variableIsNotDefinedUsedInSingleFragment {
|
||||
@ -560,7 +566,35 @@ spec =
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "noUnusedVariablesRule" $
|
||||
it "gets variable location inside an input object" $
|
||||
let queryString = [gql|
|
||||
query {
|
||||
findDog (complex: { name: $name }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message = "Variable \"$name\" is not defined."
|
||||
, locations = [AST.Location 2 29]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "gets variable location inside an array" $
|
||||
let queryString = [gql|
|
||||
query {
|
||||
findCats (commands: [JUMP, $command]) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message = "Variable \"$command\" is not defined."
|
||||
, locations = [AST.Location 2 30]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "noUnusedVariablesRule" $ do
|
||||
it "rejects unused variables" $
|
||||
let queryString = [gql|
|
||||
query variableUnused($atOtherHomes: Boolean) {
|
||||
@ -577,6 +611,16 @@ spec =
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "detects variables in properties of input objects" $
|
||||
let queryString = [gql|
|
||||
query withVar ($name: String!) {
|
||||
findDog (complex: { name: $name }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
in validate queryString `shouldBe` []
|
||||
|
||||
context "uniqueInputFieldNamesRule" $
|
||||
it "rejects duplicate fields in input objects" $
|
||||
let queryString = [gql|
|
||||
@ -878,7 +922,7 @@ spec =
|
||||
{ message =
|
||||
"Variable \"$dogCommandArg\" of type \
|
||||
\\"DogCommand\" used in position expecting type \
|
||||
\\"!DogCommand\"."
|
||||
\\"DogCommand!\"."
|
||||
, locations = [AST.Location 1 26]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
@ -925,7 +969,7 @@ spec =
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Value 3 cannot be coerced to type \"!CatCommand\"."
|
||||
"Value 3 cannot be coerced to type \"CatCommand!\"."
|
||||
, locations = [AST.Location 3 36]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
@ -940,7 +984,7 @@ spec =
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Value 3 cannot be coerced to type \"!String\"."
|
||||
"Value 3 cannot be coerced to type \"String!\"."
|
||||
, locations = [AST.Location 2 28]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
70
tests/Schemas/HeroSchema.hs
Normal file
70
tests/Schemas/HeroSchema.hs
Normal file
@ -0,0 +1,70 @@
|
||||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Schemas.HeroSchema (heroSchema) where
|
||||
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Language.GraphQL.Error (ResolverException (..))
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type.Schema (schemaWithTypes)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Typeable (cast)
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
data HeroException = HeroException
|
||||
deriving Show
|
||||
|
||||
instance Exception HeroException where
|
||||
toException = toException. ResolverException
|
||||
fromException e = do
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
heroSchema :: Type.Schema IO
|
||||
heroSchema =
|
||||
schemaWithTypes Nothing queryType Nothing Nothing [] mempty
|
||||
|
||||
type ObjectType = Out.ObjectType IO
|
||||
|
||||
queryType :: ObjectType
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("hero", Out.ValueResolver heroField heroResolver)
|
||||
]
|
||||
where
|
||||
heroField = Out.Field Nothing (Out.NamedObjectType heroType)
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
|
||||
heroResolver = pure $ Type.Object mempty
|
||||
|
||||
stringField :: Out.Field IO
|
||||
stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
|
||||
|
||||
heroType :: ObjectType
|
||||
heroType = Out.ObjectType "Hero" Nothing [] $ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("id", Out.ValueResolver stringField (pure $ Type.String "4111"))
|
||||
, ("name", Out.ValueResolver stringField (pure $ Type.String "R2D2"))
|
||||
, ("friends", Out.ValueResolver friendsField (pure $ Type.List [luke]))
|
||||
]
|
||||
friendsField = Out.Field Nothing (Out.ListType $ Out.NonNullObjectType lukeType) HashMap.empty
|
||||
-- This list values are ignored because of current realisation (types and resolvers are the same entity)
|
||||
-- The values from lukeType will be used
|
||||
luke = Type.Object $ HashMap.fromList
|
||||
[ ("id", "dfdfdf")
|
||||
, ("name", "dfdfdff")
|
||||
]
|
||||
|
||||
lukeType :: ObjectType
|
||||
lukeType = Out.ObjectType "Luke" Nothing [] $ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("id", Out.ValueResolver stringField (pure $ Type.String "1000"))
|
||||
, ("name", Out.ValueResolver stringField (throwM HeroException))
|
||||
]
|
Reference in New Issue
Block a user