40 Commits

Author SHA1 Message Date
1c4584abdd Add a release task
Some checks failed
Build / audit (push) Successful in 13m31s
Build / test (push) Successful in 6m11s
Build / doc (push) Successful in 5m23s
Release / release (push) Failing after 16s
2024-05-01 16:38:17 +02:00
e071553e75 Update QuickCheck and containers
All checks were successful
Build / audit (push) Successful in 13m26s
Build / test (push) Successful in 6m12s
Build / doc (push) Successful in 5m17s
2024-05-01 14:06:33 +02:00
e731c7db07 Remove deprecated symbols from the Error module
All checks were successful
Build / audit (push) Successful in 14m21s
Build / test (push) Successful in 6m22s
Build / doc (push) Successful in 5m33s
2024-04-04 18:51:58 +02:00
303cf18d77 Switch to haskell images in the CI
All checks were successful
Build / audit (push) Successful in 13m52s
Build / test (push) Successful in 6m12s
Build / doc (push) Successful in 5m18s
2024-04-03 18:17:23 +02:00
6b8346e527 Update hlint to 3.8
All checks were successful
Build / audit (push) Successful in 13m37s
Build / test (push) Successful in 6m16s
Build / doc (push) Successful in 6m20s
2024-04-02 22:06:16 +02:00
303f84ed41 Release 1.2.0.3
All checks were successful
Build / audit (push) Successful in 15m3s
Build / test (push) Successful in 8m10s
Build / doc (push) Successful in 6m52s
2024-01-09 14:29:54 +01:00
d2ea9fb467 Release 1.2.0.2
All checks were successful
Build / audit (push) Successful in 15m2s
Build / test (push) Successful in 8m0s
Build / doc (push) Successful in 6m51s
2024-01-08 22:29:58 +01:00
809f446ff1 Fix variable location in objects and lists
All checks were successful
Build / audit (push) Successful in 15m35s
Build / test (push) Successful in 8m6s
Build / doc (push) Successful in 6m59s
2024-01-05 20:46:02 +01:00
b1b6bfcdb9 Add a test for the wrong variable location
All checks were successful
Build / audit (push) Successful in 16m30s
Build / test (push) Successful in 8m26s
Build / doc (push) Successful in 7m6s
inside an input object for the role checking for unused and undefined
variables.
2023-12-28 09:45:39 +01:00
59aa010f0b Fix "variable is not used" error
All checks were successful
Build / audit (pull_request) Successful in 16m24s
Build / test (pull_request) Successful in 9m2s
Build / doc (pull_request) Successful in 7m22s
Build / audit (push) Successful in 16m16s
Build / test (push) Successful in 8m29s
Build / doc (push) Successful in 7m36s
2023-12-27 12:50:17 +01:00
b1c5a568dd Add a failing test for unused variables bug
All checks were successful
Build / audit (push) Successful in 15m27s
Build / test (push) Successful in 8m32s
Build / doc (push) Successful in 7m24s
2023-12-21 21:34:37 +01:00
5ffe8c72fa Add a workflow
All checks were successful
Build / audit (push) Successful in 16m26s
Build / test (push) Successful in 7m51s
Build / doc (push) Successful in 6m26s
2023-11-27 13:00:55 +01:00
a961b168db Add a test for the input object coercion issue 2023-11-08 20:08:47 +01:00
a1cda38e20 Fix values not being coerced to lists 2023-11-04 13:46:10 +01:00
7c78497e04 Add a CHANGELOG entry for the show type fix 2023-10-14 16:40:19 +02:00
fdc43e4e25 Fix non nullable type representation
…in executor error messages.
2023-10-13 20:42:24 +02:00
2fdf04f54a Remove leading carriage return in gql 2023-08-03 08:00:36 +02:00
3ed7dcd401 Support hspec 2.11 2023-04-25 08:51:18 +02:00
408dfb4301 Update web links
All checks were successful
test Test.
2023-03-23 09:46:04 +01:00
3b69dac371 Release 1.2.0.0
All checks were successful
test Test.
2023-02-28 17:54:02 +01:00
2834360411 Remove JSON support in the core package 2023-02-26 09:43:43 +01:00
83f2dc1a2d Encode type extensions 2023-02-25 10:15:22 +01:00
3b0da4f3d7 Fix resolvers returning a list in the reverse order 2023-02-24 17:14:43 +01:00
d83f75b341 Encode schema extensions 2023-01-26 06:47:44 +01:00
85d876e131 Update the 2023 copyright 2023-01-12 13:02:50 +01:00
05fa5df558 Encode directive definitions 2023-01-11 10:28:45 +01:00
9021f3a25d Encode input object types 2023-01-10 09:53:18 +01:00
025331a9ee Encode enums 2023-01-09 20:56:21 +01:00
ab4808c44d Encode unions 2023-01-08 17:33:25 +01:00
bb4375313e Encode object type definitions 2023-01-03 13:10:33 +01:00
70dedb6911 Encode interfaces (2018) 2023-01-02 10:30:37 +01:00
a96d4e6ef3 Add Semigroup and Monoid instances for Description 2022-12-27 10:38:08 +01:00
3ce6e7da46 Encode schema definitions 2022-12-25 16:38:00 +01:00
a5cf0a32e8 Replace ">> pure ()" with void 2022-12-24 18:59:40 +01:00
2f9881bb21 Fix GHC 9.2 warnings and deprecations
- Fix GHC 9.2 warnings
- Convert comments to proper deprecations
2022-12-24 18:09:52 +01:00
bf2e4925b4 Add operation type encoder 2022-10-02 11:38:53 +02:00
2321d1a1bc Eliminate non-exhaustive patterns in ExecuteSpec 2022-07-02 15:29:35 +02:00
2f19093803 Change execute' to shouldResolveTo helper method 2022-07-01 12:18:02 +02:00
0dac9701bc Document usage of the json flag 2022-06-30 11:10:46 +02:00
0d25f482dd Remove deprecated Error functions 2022-03-31 21:49:44 +02:00
24 changed files with 868 additions and 528 deletions

View 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

View 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}

View File

@ -6,6 +6,54 @@ 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
@ -372,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]`
@ -477,22 +524,28 @@ and this project adheres to
### Added
- Data types for the GraphQL language.
[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.3.0&rev_to=v1.0.2.0
[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

View File

@ -1,15 +1,12 @@
# GraphQL implementation in Haskell
[![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
[![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](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).

View File

@ -1,17 +1,17 @@
cabal-version: 2.4
name: graphql
version: 1.0.3.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,17 +21,12 @@ extra-source-files:
CHANGELOG.md
README.md
tested-with:
GHC == 8.10.7,
GHC == 9.2.2
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:
@ -53,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
@ -66,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 && < 3,
transformers ^>= 0.5.6,
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
@ -105,16 +93,19 @@ test-suite graphql-test
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,
containers,
vector
build-tool-depends:
hspec-discover:hspec-discover
default-language: Haskell2010

View File

@ -1,81 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
#ifdef WITH_JSON
-- | 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 qualified Data.Sequence as Seq
import Data.Text (Text)
import Language.GraphQL.AST
import Language.GraphQL.Error
import Language.GraphQL.Execute
import qualified Language.GraphQL.Validate as Validate
import Language.GraphQL.Type.Schema (Schema)
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
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
-> Aeson.Object -- ^ 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
Right parsed ->
case validate parsed of
Seq.Empty -> fmap formatResponse
<$> execute schema operationName variableValues parsed
errors -> pure $ pure
$ HashMap.singleton "errors"
$ Aeson.toJSON
$ 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
( graphql
@ -120,4 +44,3 @@ graphql schema operationName variableValues document' =
, locations = locations
, path = []
}
#endif

View File

@ -371,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
@ -464,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.

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)
@ -466,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) =
@ -555,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

View File

@ -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

View File

@ -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

View File

@ -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, "]!"]

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -7,6 +7,7 @@ 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)
@ -59,34 +60,36 @@ instance Arbitrary a => Arbitrary (AnyObjectField a) where
location' <- getAnyLocation <$> arbitrary
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show)
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value }
deriving (Eq, Show)
instance Arbitrary AnyValue where
arbitrary = 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
]
where
variableGen :: Gen Doc.Value
variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
listGen :: Gen [Doc.Node Doc.Value]
listGen = (resize 5 . listOf) nodeGen
nodeGen = do
node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
pure (getAnyValue <$> node')
objectGen :: Gen [Doc.ObjectField Doc.Value]
objectGen = resize 1 $ do
list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
pure $ map (fmap getAnyValue . getAnyObjectField) list
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)
newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument }
deriving (Eq, Show)
instance Arbitrary a => Arbitrary (AnyArgument a) where
arbitrary = do

View File

@ -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

View File

@ -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

View File

@ -2,6 +2,10 @@
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 #-}
@ -9,7 +13,7 @@ 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)
@ -27,11 +31,17 @@ 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
@ -42,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
@ -52,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 =
@ -65,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
@ -85,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
@ -95,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
@ -139,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
@ -156,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
@ -166,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)
@ -175,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
@ -192,12 +222,48 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
]
type EitherStreamOrValue = Either
(ResponseEventStream (Either SomeException) Type.Value)
(ResponseEventStream IO Type.Value)
(Response Type.Value)
execute' :: Document -> Either SomeException EitherStreamOrValue
execute' =
execute philosopherSchema Nothing (mempty :: HashMap Name Type.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 =
@ -213,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" $
@ -225,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"
@ -237,135 +300,129 @@ 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"
startsWith :: Text.Text -> Text.Text -> Bool
startsWith xs ys = Text.take (Text.length ys) xs == ys
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
it "throws operation name is required error" $
let expectedErrorMessage :: Text.Text
expectedErrorMessage = "Operation name is required"
Right (Right (Response _ executionErrors)) = either (pure . parseError) execute' $ parse document "" twoQueries
Error msg _ _ = Seq.index executionErrors 0
in msg `startsWith` expectedErrorMessage `shouldBe` True
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" $
let expectedErrorMessage :: Text.Text
expectedErrorMessage = "Operation \"C\" is not found"
execute'' :: Document -> Either SomeException EitherStreamOrValue
execute'' = execute philosopherSchema (Just "C") (mempty :: HashMap Name Type.Value)
Right (Right (Response _ executionErrors)) = either (pure . parseError) execute''
$ parse document "" twoQueries
Error msg _ _ = Seq.index executionErrors 0
in msg `startsWith` expectedErrorMessage `shouldBe` True
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" $
it "throws variable coercion error" $ do
let data'' = Null
executionErrors = pure $ Error
{ message = "Failed to coerce the variable $id: String."
@ -373,11 +430,10 @@ spec =
, path = []
}
expected = Response data'' executionErrors
executeWithVars :: Document -> Either SomeException EitherStreamOrValue
executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
Right (Right actual) = either (pure . parseError) executeWithVars
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
in actual `shouldBe` expected
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
@ -387,31 +443,31 @@ spec =
, path = []
}
expected = Response data'' executionErrors
Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
in actual `shouldBe` expected
sourceQuery = "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
in sourceQuery `shouldResolveTo` expected
context "Error path" $ do
let executeHero :: Document -> Either SomeException EitherStreamOrValue
let executeHero :: Document -> IO EitherStreamOrValue
executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Type.Value)
it "at the beggining of the list" $
let Right (Right actual) = either (pure . parseError) executeHero
$ parse document "" "{ hero(id: \"1\") { friends { name } } }"
Response _ errors' = actual
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
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

View File

@ -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]

View File

@ -6,7 +6,7 @@
module Schemas.HeroSchema (heroSchema) where
import Control.Exception (Exception(..), SomeException)
import Control.Exception (Exception(..))
import Control.Monad.Catch (throwM)
import Language.GraphQL.Error (ResolverException (..))
import qualified Language.GraphQL.Type.In as In
@ -25,11 +25,11 @@ instance Exception HeroException where
ResolverException resolverException <- fromException e
cast resolverException
heroSchema :: Type.Schema (Either SomeException)
heroSchema :: Type.Schema IO
heroSchema =
schemaWithTypes Nothing queryType Nothing Nothing [] mempty
type ObjectType = Out.ObjectType (Either SomeException)
type ObjectType = Out.ObjectType IO
queryType :: ObjectType
queryType = Out.ObjectType "Query" Nothing []
@ -42,7 +42,7 @@ queryType = Out.ObjectType "Query" Nothing []
$ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
heroResolver = pure $ Type.Object mempty
stringField :: Out.Field (Either SomeException)
stringField :: Out.Field IO
stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
heroType :: ObjectType