Compare commits
26 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | dd6fdf69f6 | |
Eugen Wissner | b99bb72272 | |
Eugen Wissner | b580d1a988 | |
Eugen Wissner | c601ccb4ad | |
Eugen Wissner | 96bb061666 | |
Eugen Wissner | 812f6967d4 | |
Eugen Wissner | 6fe9eb72e4 | |
Eugen Wissner | 2ce2be5d91 | |
Eugen Wissner | c311cb0070 | |
Eugen Wissner | 1b7cd85216 | |
Eugen Wissner | f671645043 | |
Eugen Wissner | 1af95345d2 | |
Eugen Wissner | 0d23df3da2 | |
Eugen Wissner | 5a5f265fe4 | |
Eugen Wissner | 2220f0ca56 | |
Eugen Wissner | 5654b78935 | |
Eugen Wissner | d6dda14cfd | |
Eugen Wissner | 328e6acdee | |
Eugen Wissner | 4d762d6356 | |
Ben Sinclair | cbccb9ed0b | |
Ben Sinclair | ca0f0bd32d | |
Eugen Wissner | 10e4d64052 | |
Eugen Wissner | d74e27e903 | |
Eugen Wissner | 90d36f66b9 | |
Eugen Wissner | c1a1b47aea | |
Eugen Wissner | 1e8405a6d6 |
33
CHANGELOG.md
33
CHANGELOG.md
|
@ -6,6 +6,36 @@ The format is based on
|
|||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [1.0.0.0]
|
||||
### Added
|
||||
- `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves
|
||||
insertion order.
|
||||
- `Language.GraphQL.Schema.schemaWithTypes` constructs a complete schema,
|
||||
including an optional schema description and user-defined types not referenced
|
||||
in the schema directly (for example interface implementations).
|
||||
- `Language.GraphQL.Schema.description` returns the optional schema description.
|
||||
- All errors that can be associated with a location in the query contain
|
||||
location information.
|
||||
|
||||
### Fixed
|
||||
- Parser now accepts empty lists and objects.
|
||||
- Parser now accepts all directive locations.
|
||||
- `valuesOfCorrectTypeRule` doesn't check lists recursively since the
|
||||
validation traverser calls it on all list items.
|
||||
- `valuesOfCorrectTypeRule` doesn't check objects recursively since the
|
||||
validation traverser calls it on all object properties.
|
||||
- Validation of non-nullable values inside lists.
|
||||
- `executeField` shouldn't assume that a selection has only one field with a
|
||||
given name, but it should take the first field. The underlying cause is a
|
||||
wrong pattern, which (because of the laziness) is executed only if the field
|
||||
has arguments.
|
||||
|
||||
### Changed
|
||||
- `AST.Document.Value.List` and `AST.Document.ConstValue.ConstList` contain
|
||||
location information for each list item.
|
||||
- `Error`: `singleError`, `addErr` and `addErrMsg` are deprecated. They are
|
||||
internal functions used by the executor for error handling.
|
||||
|
||||
## [0.11.1.0] - 2021-02-07
|
||||
### Added
|
||||
- `Validate.Rules`:
|
||||
|
@ -104,7 +134,7 @@ and this project adheres to
|
|||
`locations`.
|
||||
- Parsing comments in the front of definitions.
|
||||
- Some missing labels were added to the parsers, some labels were fixed to
|
||||
refer to the AST nodes being parsed.
|
||||
refer to the AST nodes being parsed.
|
||||
|
||||
### Added
|
||||
- `AST` reexports `AST.Parser`.
|
||||
|
@ -413,6 +443,7 @@ and this project adheres to
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[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
|
||||
|
|
|
@ -1,13 +1,7 @@
|
|||
cabal-version: 2.2
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.33.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 15a0880180192f918ba0bd3b3e955c57232f1efe8993745d505fcb6e1aab1451
|
||||
|
||||
name: graphql
|
||||
version: 0.11.1.0
|
||||
version: 1.0.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
|
@ -26,6 +20,7 @@ build-type: Simple
|
|||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
tested-with: GHC == 8.10.4
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
@ -43,6 +38,7 @@ library
|
|||
Language.GraphQL.Error
|
||||
Language.GraphQL.Execute
|
||||
Language.GraphQL.Execute.Coerce
|
||||
Language.GraphQL.Execute.OrderedMap
|
||||
Language.GraphQL.Type
|
||||
Language.GraphQL.Type.In
|
||||
Language.GraphQL.Type.Out
|
||||
|
@ -52,6 +48,7 @@ library
|
|||
Test.Hspec.GraphQL
|
||||
other-modules:
|
||||
Language.GraphQL.Execute.Execution
|
||||
Language.GraphQL.Execute.Internal
|
||||
Language.GraphQL.Execute.Subscribe
|
||||
Language.GraphQL.Execute.Transform
|
||||
Language.GraphQL.Type.Definition
|
||||
|
@ -59,19 +56,21 @@ library
|
|||
Language.GraphQL.Validate.Rules
|
||||
hs-source-dirs:
|
||||
src
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, conduit
|
||||
, containers
|
||||
, exceptions
|
||||
, hspec-expectations
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, scientific
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
aeson >= 1.5.6 && < 1.6
|
||||
, base >= 4.7 && < 5
|
||||
, conduit >= 1.3.4 && < 1.4
|
||||
, containers >= 0.6.2 && < 0.7
|
||||
, exceptions >= 0.10.4 && < 0.11
|
||||
, hspec-expectations >= 0.8.2 && < 0.9
|
||||
, megaparsec >= 9.0.1 && < 9.1
|
||||
, parser-combinators >= 1.3.0 && < 1.4
|
||||
, scientific >= 0.3.7 && < 0.4
|
||||
, text >= 1.2.4 && < 1.3
|
||||
, transformers >= 0.5.6 && < 0.6
|
||||
, unordered-containers >= 0.2.14 && < 0.3
|
||||
, vector >= 0.12.3 && < 0.13
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite graphql-test
|
||||
|
@ -84,34 +83,28 @@ test-suite graphql-test
|
|||
Language.GraphQL.AST.ParserSpec
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.Execute.CoerceSpec
|
||||
Language.GraphQL.Execute.OrderedMapSpec
|
||||
Language.GraphQL.ExecuteSpec
|
||||
Language.GraphQL.Type.OutSpec
|
||||
Language.GraphQL.Validate.RulesSpec
|
||||
Test.DirectiveSpec
|
||||
Test.FragmentSpec
|
||||
Test.RootOperationSpec
|
||||
Paths_graphql
|
||||
autogen-modules:
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||
build-depends:
|
||||
QuickCheck
|
||||
QuickCheck >= 2.14.1 && < 2.15
|
||||
, aeson
|
||||
, base >=4.7 && <5
|
||||
, base >= 4.7 && < 5
|
||||
, conduit
|
||||
, containers
|
||||
, exceptions
|
||||
, graphql
|
||||
, hspec
|
||||
, hspec-expectations
|
||||
, hspec-megaparsec
|
||||
, hspec >= 2.8.2 && < 2.9
|
||||
, hspec-megaparsec >= 2.2.0 && < 2.3
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, raw-strings-qq
|
||||
, raw-strings-qq >= 1.1 && < 1.2
|
||||
, scientific
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
|
67
package.yaml
67
package.yaml
|
@ -1,67 +0,0 @@
|
|||
name: graphql
|
||||
version: 0.11.1.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
maintainer: belka@caraus.de
|
||||
git: git://caraus.tech/pub/graphql.git
|
||||
homepage: https://www.caraus.tech/projects/pub-graphql
|
||||
bug-reports: https://www.caraus.tech/projects/pub-graphql/issues
|
||||
category: Language
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
|
||||
copyright:
|
||||
- (c) 2019-2021 Eugen Wissner
|
||||
- (c) 2015-2017 J. Daniel Navarro
|
||||
author:
|
||||
- Danny Navarro <j@dannynavarro.net>
|
||||
- Matthías Páll Gissurarson <mpg@mpg.is>
|
||||
- Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
|
||||
license-file:
|
||||
- LICENSE
|
||||
- LICENSE.MPL
|
||||
extra-source-files:
|
||||
- CHANGELOG.md
|
||||
- README.md
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
- base >= 4.7 && < 5
|
||||
- conduit
|
||||
- containers
|
||||
- exceptions
|
||||
- hspec-expectations
|
||||
- megaparsec
|
||||
- parser-combinators
|
||||
- scientific
|
||||
- text
|
||||
- transformers
|
||||
- unordered-containers
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
other-modules:
|
||||
- Language.GraphQL.Execute.Execution
|
||||
- Language.GraphQL.Execute.Subscribe
|
||||
- Language.GraphQL.Execute.Transform
|
||||
- Language.GraphQL.Type.Definition
|
||||
- Language.GraphQL.Type.Internal
|
||||
- Language.GraphQL.Validate.Rules
|
||||
|
||||
tests:
|
||||
graphql-test:
|
||||
main: Spec.hs
|
||||
source-dirs: tests
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- graphql
|
||||
- hspec
|
||||
- hspec-megaparsec
|
||||
- QuickCheck
|
||||
- raw-strings-qq
|
||||
generated-other-modules:
|
||||
- Paths_graphql
|
|
@ -226,6 +226,12 @@ type TypeCondition = Name
|
|||
|
||||
-- ** Input Values
|
||||
|
||||
-- | Escapes a single character according to the GraphQL escaping rules for
|
||||
-- double-quoted string values.
|
||||
--
|
||||
-- Characters, that should be escaped, are written as escaped characters with a
|
||||
-- backslash or Unicode with an \"\\u\". Other characters are returned as
|
||||
-- strings.
|
||||
escape :: Char -> String
|
||||
escape char'
|
||||
| char' == '\\' = "\\\\"
|
||||
|
@ -257,7 +263,7 @@ data Value
|
|||
| Boolean Bool
|
||||
| Null
|
||||
| Enum Name
|
||||
| List [Value]
|
||||
| List [Node Value]
|
||||
| Object [ObjectField Value]
|
||||
deriving Eq
|
||||
|
||||
|
@ -281,7 +287,7 @@ data ConstValue
|
|||
| ConstBoolean Bool
|
||||
| ConstNull
|
||||
| ConstEnum Name
|
||||
| ConstList [ConstValue]
|
||||
| ConstList [Node ConstValue]
|
||||
| ConstObject [ObjectField ConstValue]
|
||||
deriving Eq
|
||||
|
||||
|
@ -318,13 +324,13 @@ instance Functor ObjectField where
|
|||
-- Each operation can include a list of variables:
|
||||
--
|
||||
-- @
|
||||
-- query (protagonist: String = "Zarathustra") {
|
||||
-- query (protagonist: String = \"Zarathustra\") {
|
||||
-- getAuthor(protagonist: $protagonist)
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- This query defines an optional variable @protagonist@ of type @String@,
|
||||
-- its default value is "Zarathustra". If no default value is defined and no
|
||||
-- its default value is \"Zarathustra\". If no default value is defined and no
|
||||
-- value is provided, a variable can still be @null@ if its type is nullable.
|
||||
--
|
||||
-- Variables are usually passed along with the query, but not in the query
|
||||
|
|
|
@ -219,7 +219,7 @@ fromConstValue (Full.ConstBoolean x) = Full.Boolean x
|
|||
fromConstValue Full.ConstNull = Full.Null
|
||||
fromConstValue (Full.ConstString string) = Full.String string
|
||||
fromConstValue (Full.ConstEnum x) = Full.Enum x
|
||||
fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x
|
||||
fromConstValue (Full.ConstList x) = Full.List $ fmap fromConstValue <$> x
|
||||
fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
|
||||
where
|
||||
fromConstObjectField Full.ObjectField{value = value', ..} =
|
||||
|
@ -266,8 +266,8 @@ stringValue (Pretty indentation) string =
|
|||
= Builder.fromLazyText (indent (indentation + 1))
|
||||
<> line' <> newline <> acc
|
||||
|
||||
listValue :: Formatter -> [Full.Value] -> Lazy.Text
|
||||
listValue formatter = bracketsCommas formatter $ value formatter
|
||||
listValue :: Formatter -> [Full.Node Full.Value] -> Lazy.Text
|
||||
listValue formatter = bracketsCommas formatter $ value formatter . Full.node
|
||||
|
||||
objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text
|
||||
objectValue formatter = intercalate $ objectField formatter
|
||||
|
|
|
@ -14,11 +14,7 @@ import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
|||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as Directive
|
||||
import Language.GraphQL.AST.DirectiveLocation
|
||||
( DirectiveLocation
|
||||
, ExecutableDirectiveLocation
|
||||
, TypeSystemDirectiveLocation
|
||||
)
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.AST.Lexer
|
||||
import Text.Megaparsec
|
||||
|
@ -96,34 +92,28 @@ directiveLocations = optional pipe
|
|||
<?> "DirectiveLocations"
|
||||
|
||||
directiveLocation :: Parser DirectiveLocation
|
||||
directiveLocation
|
||||
= Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
|
||||
<|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
|
||||
directiveLocation = e (Directive.Query <$ symbol "QUERY")
|
||||
<|> e (Directive.Mutation <$ symbol "MUTATION")
|
||||
<|> e (Directive.Subscription <$ symbol "SUBSCRIPTION")
|
||||
<|> t (Directive.FieldDefinition <$ symbol "FIELD_DEFINITION")
|
||||
<|> e (Directive.Field <$ symbol "FIELD")
|
||||
<|> e (Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION")
|
||||
<|> e (Directive.FragmentSpread <$ "FRAGMENT_SPREAD")
|
||||
<|> e (Directive.InlineFragment <$ "INLINE_FRAGMENT")
|
||||
<|> t (Directive.Schema <$ symbol "SCHEMA")
|
||||
<|> t (Directive.Scalar <$ symbol "SCALAR")
|
||||
<|> t (Directive.Object <$ symbol "OBJECT")
|
||||
<|> t (Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION")
|
||||
<|> t (Directive.Interface <$ symbol "INTERFACE")
|
||||
<|> t (Directive.Union <$ symbol "UNION")
|
||||
<|> t (Directive.EnumValue <$ symbol "ENUM_VALUE")
|
||||
<|> t (Directive.Enum <$ symbol "ENUM")
|
||||
<|> t (Directive.InputObject <$ symbol "INPUT_OBJECT")
|
||||
<|> t (Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION")
|
||||
<?> "DirectiveLocation"
|
||||
|
||||
executableDirectiveLocation :: Parser ExecutableDirectiveLocation
|
||||
executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
|
||||
<|> Directive.Mutation <$ symbol "MUTATION"
|
||||
<|> Directive.Subscription <$ symbol "SUBSCRIPTION"
|
||||
<|> Directive.Field <$ symbol "FIELD"
|
||||
<|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
|
||||
<|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
|
||||
<|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
|
||||
<?> "ExecutableDirectiveLocation"
|
||||
|
||||
typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
|
||||
typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
|
||||
<|> Directive.Scalar <$ symbol "SCALAR"
|
||||
<|> Directive.Object <$ symbol "OBJECT"
|
||||
<|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
|
||||
<|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
|
||||
<|> Directive.Interface <$ symbol "INTERFACE"
|
||||
<|> Directive.Union <$ symbol "UNION"
|
||||
<|> Directive.Enum <$ symbol "ENUM"
|
||||
<|> Directive.EnumValue <$ symbol "ENUM_VALUE"
|
||||
<|> Directive.InputObject <$ symbol "INPUT_OBJECT"
|
||||
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
|
||||
<?> "TypeSystemDirectiveLocation"
|
||||
where
|
||||
e = fmap Directive.ExecutableDirectiveLocation
|
||||
t = fmap Directive.TypeSystemDirectiveLocation
|
||||
|
||||
typeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
||||
typeDefinition description' = scalarTypeDefinition description'
|
||||
|
@ -460,7 +450,7 @@ value = Full.Variable <$> variable
|
|||
<|> Full.Null <$ nullValue
|
||||
<|> Full.String <$> stringValue
|
||||
<|> Full.Enum <$> try enumValue
|
||||
<|> Full.List <$> brackets (some value)
|
||||
<|> Full.List <$> brackets (some $ valueNode value)
|
||||
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
|
||||
<?> "Value"
|
||||
|
||||
|
@ -471,8 +461,8 @@ constValue = Full.ConstFloat <$> try float
|
|||
<|> Full.ConstNull <$ nullValue
|
||||
<|> Full.ConstString <$> stringValue
|
||||
<|> Full.ConstEnum <$> try enumValue
|
||||
<|> Full.ConstList <$> brackets (some constValue)
|
||||
<|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue)
|
||||
<|> Full.ConstList <$> brackets (many $ valueNode constValue)
|
||||
<|> Full.ConstObject <$> braces (many $ objectField $ valueNode constValue)
|
||||
<?> "Value"
|
||||
|
||||
booleanValue :: Parser Bool
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Error handling.
|
||||
|
@ -70,21 +69,25 @@ parseError ParseErrorBundle{..} =
|
|||
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 $ makeErrorMessage message
|
||||
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
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
|
||||
-- | This module provides functions to execute a @GraphQL@ request.
|
||||
module Language.GraphQL.Execute
|
||||
|
@ -10,15 +10,22 @@ import Control.Monad.Catch (MonadCatch)
|
|||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Document (Document, Name)
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Execution
|
||||
import Language.GraphQL.Execute.Internal
|
||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||
import qualified Language.GraphQL.Execute.Subscribe as Subscribe
|
||||
import Language.GraphQL.Error
|
||||
( Error
|
||||
, ResponseEventStream
|
||||
, Response(..)
|
||||
, runCollectErrs
|
||||
)
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Prelude hiding (null)
|
||||
|
||||
-- | The substitution is applied to the document, and the resolvers are applied
|
||||
-- to the resulting fields. The operation name can be used if the document
|
||||
|
@ -29,35 +36,36 @@ import Language.GraphQL.Type.Schema
|
|||
execute :: (MonadCatch m, VariableValue a, Serialize b)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> HashMap Name a -- ^ Variable substitution function.
|
||||
-> Document -- @GraphQL@ document.
|
||||
-> HashMap Full.Name a -- ^ Variable substitution function.
|
||||
-> Full.Document -- @GraphQL@ document.
|
||||
-> m (Either (ResponseEventStream m b) (Response b))
|
||||
execute schema' operationName subs document =
|
||||
case Transform.document schema' operationName subs document of
|
||||
Left queryError -> pure
|
||||
$ Right
|
||||
$ singleError
|
||||
$ Transform.queryError queryError
|
||||
Right transformed -> executeRequest transformed
|
||||
execute schema' operationName subs document
|
||||
= either (pure . rightErrorResponse . singleError [] . show) executeRequest
|
||||
$ Transform.document schema' operationName subs document
|
||||
|
||||
executeRequest :: (MonadCatch m, Serialize a)
|
||||
=> Transform.Document m
|
||||
-> m (Either (ResponseEventStream m a) (Response a))
|
||||
executeRequest (Transform.Document types' rootObjectType operation)
|
||||
| (Transform.Query _ fields) <- operation =
|
||||
Right <$> executeOperation types' rootObjectType fields
|
||||
| (Transform.Mutation _ fields) <- operation =
|
||||
Right <$> executeOperation types' rootObjectType fields
|
||||
| (Transform.Subscription _ fields) <- operation
|
||||
= either (Right . singleError) Left
|
||||
<$> Subscribe.subscribe types' rootObjectType fields
|
||||
| (Transform.Query _ fields objectLocation) <- operation =
|
||||
Right <$> executeOperation types' rootObjectType objectLocation fields
|
||||
| (Transform.Mutation _ fields objectLocation) <- operation =
|
||||
Right <$> executeOperation types' rootObjectType objectLocation fields
|
||||
| (Transform.Subscription _ fields objectLocation) <- operation
|
||||
= either rightErrorResponse Left
|
||||
<$> Subscribe.subscribe types' rootObjectType objectLocation fields
|
||||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
executeOperation :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
=> HashMap Full.Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Full.Location
|
||||
-> Seq (Transform.Selection m)
|
||||
-> m (Response a)
|
||||
executeOperation types' objectType fields =
|
||||
runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
|
||||
executeOperation types' objectType objectLocation fields
|
||||
= runCollectErrs types'
|
||||
$ executeSelectionSet Definition.Null objectType objectLocation fields
|
||||
|
||||
rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
|
||||
rightErrorResponse = Right . Response null . pure
|
||||
|
|
|
@ -19,7 +19,6 @@ import qualified Data.Aeson as Aeson
|
|||
import Data.Int (Int32)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.String (IsString(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
|
@ -27,6 +26,8 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
|
|||
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
|
||||
import Data.Scientific (toBoundedInteger, toRealFloat)
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
|
||||
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
@ -209,7 +210,7 @@ data Output a
|
|||
| Boolean Bool
|
||||
| Enum Name
|
||||
| List [a]
|
||||
| Object (Map Name a)
|
||||
| Object (OrderedMap a)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance forall a. IsString (Output a) where
|
||||
|
@ -229,6 +230,9 @@ instance Serialize Aeson.Value where
|
|||
, 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.toJSON object
|
||||
serialize _ (Object object) = Just
|
||||
$ Aeson.object
|
||||
$ OrderedMap.toList
|
||||
$ Aeson.toJSON <$> object
|
||||
serialize _ _ = Nothing
|
||||
null = Aeson.Null
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
|
@ -13,16 +14,18 @@ import Control.Monad.Trans.Class (lift)
|
|||
import Control.Monad.Trans.Reader (runReaderT)
|
||||
import Control.Monad.Trans.State (gets)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Sequence (Seq(..))
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Name)
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Internal
|
||||
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
|
||||
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
|
||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
|
@ -34,15 +37,17 @@ resolveFieldValue :: MonadCatch m
|
|||
=> Type.Value
|
||||
-> Type.Subs
|
||||
-> Type.Resolve m
|
||||
-> Full.Location
|
||||
-> CollectErrsT m Type.Value
|
||||
resolveFieldValue result args resolver =
|
||||
resolveFieldValue result args resolver location' =
|
||||
catch (lift $ runReaderT resolver context) handleFieldError
|
||||
where
|
||||
handleFieldError :: MonadCatch m
|
||||
=> ResolverException
|
||||
-> CollectErrsT m Type.Value
|
||||
handleFieldError e =
|
||||
addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
|
||||
handleFieldError e
|
||||
= addError Type.Null
|
||||
$ Error (Text.pack $ displayException e) [location'] []
|
||||
context = Type.Context
|
||||
{ Type.arguments = Type.Arguments args
|
||||
, Type.values = result
|
||||
|
@ -51,21 +56,21 @@ resolveFieldValue result args resolver =
|
|||
collectFields :: Monad m
|
||||
=> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
-> Map Name (NonEmpty (Transform.Field m))
|
||||
collectFields objectType = foldl forEach Map.empty
|
||||
-> OrderedMap (NonEmpty (Transform.Field m))
|
||||
collectFields objectType = foldl forEach OrderedMap.empty
|
||||
where
|
||||
forEach groupedFields (Transform.SelectionField field) =
|
||||
let responseKey = aliasOrName field
|
||||
in Map.insertWith (<>) responseKey (field :| []) groupedFields
|
||||
in OrderedMap.insert responseKey (field :| []) groupedFields
|
||||
forEach groupedFields (Transform.SelectionFragment selectionFragment)
|
||||
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
||||
, Internal.doesFragmentTypeApply fragmentType objectType =
|
||||
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
||||
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
||||
in groupedFields <> fragmentGroupedFieldSet
|
||||
| otherwise = groupedFields
|
||||
|
||||
aliasOrName :: forall m. Transform.Field m -> Name
|
||||
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
|
||||
aliasOrName :: forall m. Transform.Field m -> Full.Name
|
||||
aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
|
||||
|
||||
resolveAbstractType :: Monad m
|
||||
=> Internal.AbstractType m
|
||||
|
@ -95,11 +100,15 @@ executeField fieldResolver prev fields
|
|||
where
|
||||
executeField' fieldDefinition resolver = do
|
||||
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
|
||||
let (Transform.Field _ _ arguments' _ :| []) = fields
|
||||
let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields
|
||||
case coerceArgumentValues argumentDefinitions arguments' of
|
||||
Nothing -> addErrMsg "Argument coercing failed."
|
||||
Just argumentValues -> do
|
||||
answer <- resolveFieldValue prev argumentValues resolver
|
||||
Left [] ->
|
||||
let errorMessage = "Not all required arguments are specified."
|
||||
in addError null $ Error errorMessage [location'] []
|
||||
Left errorLocations -> addError null
|
||||
$ Error "Argument coercing failed." errorLocations []
|
||||
Right argumentValues -> do
|
||||
answer <- resolveFieldValue prev argumentValues resolver location'
|
||||
completeValue fieldType fields answer
|
||||
|
||||
completeValue :: (MonadCatch m, Serialize a)
|
||||
|
@ -110,55 +119,67 @@ completeValue :: (MonadCatch m, Serialize a)
|
|||
completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
|
||||
completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
|
||||
= traverse (completeValue listType fields) list
|
||||
>>= coerceResult outputType . List
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
|
||||
coerceResult outputType $ Int int
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
|
||||
coerceResult outputType $ Boolean boolean
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
|
||||
coerceResult outputType $ Float float
|
||||
completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
|
||||
coerceResult outputType $ String string
|
||||
completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
|
||||
>>= coerceResult outputType (firstFieldLocation fields) . List
|
||||
completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =
|
||||
coerceResult outputType (firstFieldLocation fields) $ Int int
|
||||
completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =
|
||||
coerceResult outputType (firstFieldLocation fields) $ Boolean boolean
|
||||
completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =
|
||||
coerceResult outputType (firstFieldLocation fields) $ Float float
|
||||
completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =
|
||||
coerceResult outputType (firstFieldLocation fields) $ String string
|
||||
completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
|
||||
let Type.EnumType _ _ enumMembers = enumType
|
||||
location = firstFieldLocation fields
|
||||
in if HashMap.member enum enumMembers
|
||||
then coerceResult outputType $ Enum enum
|
||||
else addErrMsg "Enum value completion failed."
|
||||
completeValue (Out.ObjectBaseType objectType) fields result =
|
||||
executeSelectionSet result objectType $ mergeSelectionSets fields
|
||||
then coerceResult outputType location $ Enum enum
|
||||
else addError null $ Error "Enum value completion failed." [location] []
|
||||
completeValue (Out.ObjectBaseType objectType) fields result
|
||||
= executeSelectionSet result objectType (firstFieldLocation fields)
|
||||
$ mergeSelectionSets fields
|
||||
completeValue (Out.InterfaceBaseType interfaceType) fields result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = Internal.AbstractInterfaceType interfaceType
|
||||
let location = firstFieldLocation fields
|
||||
concreteType <- resolveAbstractType abstractType objectMap
|
||||
case concreteType of
|
||||
Just objectType -> executeSelectionSet result objectType
|
||||
Just objectType -> executeSelectionSet result objectType location
|
||||
$ mergeSelectionSets fields
|
||||
Nothing -> addErrMsg "Interface value completion failed."
|
||||
Nothing -> addError null
|
||||
$ Error "Interface value completion failed." [location] []
|
||||
completeValue (Out.UnionBaseType unionType) fields result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = Internal.AbstractUnionType unionType
|
||||
let location = firstFieldLocation fields
|
||||
concreteType <- resolveAbstractType abstractType objectMap
|
||||
case concreteType of
|
||||
Just objectType -> executeSelectionSet result objectType
|
||||
$ mergeSelectionSets fields
|
||||
Nothing -> addErrMsg "Union value completion failed."
|
||||
completeValue _ _ _ = addErrMsg "Value completion failed."
|
||||
location $ mergeSelectionSets fields
|
||||
Nothing -> addError null
|
||||
$ Error "Union value completion failed." [location] []
|
||||
completeValue _ (Transform.Field _ _ _ _ location :| _) _ =
|
||||
addError null $ Error "Value completion failed." [location] []
|
||||
|
||||
mergeSelectionSets :: MonadCatch m
|
||||
=> NonEmpty (Transform.Field m)
|
||||
-> Seq (Transform.Selection m)
|
||||
mergeSelectionSets = foldr forEach mempty
|
||||
where
|
||||
forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
|
||||
forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
|
||||
selectionSet <> fieldSelectionSet
|
||||
|
||||
firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
|
||||
firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation
|
||||
|
||||
coerceResult :: (MonadCatch m, Serialize a)
|
||||
=> Out.Type m
|
||||
-> Full.Location
|
||||
-> Output a
|
||||
-> CollectErrsT m a
|
||||
coerceResult outputType result
|
||||
coerceResult outputType parentLocation result
|
||||
| Just serialized <- serialize outputType result = pure serialized
|
||||
| otherwise = addErrMsg "Result coercion failed."
|
||||
| otherwise = addError null
|
||||
$ Error "Result coercion failed." [parentLocation] []
|
||||
|
||||
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
|
||||
-- each field to each 'Transform.Selection'. Resolves into a value containing
|
||||
|
@ -166,29 +187,45 @@ coerceResult outputType result
|
|||
executeSelectionSet :: (MonadCatch m, Serialize a)
|
||||
=> Type.Value
|
||||
-> Out.ObjectType m
|
||||
-> Full.Location
|
||||
-> Seq (Transform.Selection m)
|
||||
-> CollectErrsT m a
|
||||
executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
|
||||
executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
|
||||
let fields = collectFields objectType selectionSet
|
||||
resolvedValues <- Map.traverseMaybeWithKey forEach fields
|
||||
coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
|
||||
resolvedValues <- OrderedMap.traverseMaybe forEach fields
|
||||
coerceResult (Out.NonNullObjectType objectType) objectLocation
|
||||
$ Object resolvedValues
|
||||
where
|
||||
forEach _ fields@(field :| _) =
|
||||
let Transform.Field _ name _ _ = field
|
||||
forEach fields@(field :| _) =
|
||||
let Transform.Field _ name _ _ _ = field
|
||||
in traverse (tryResolver fields) $ lookupResolver name
|
||||
lookupResolver = flip HashMap.lookup resolvers
|
||||
tryResolver fields resolver =
|
||||
executeField resolver result fields >>= lift . pure
|
||||
|
||||
coerceArgumentValues
|
||||
:: HashMap Name In.Argument
|
||||
-> HashMap Name Transform.Input
|
||||
-> Maybe Type.Subs
|
||||
coerceArgumentValues argumentDefinitions argumentValues =
|
||||
:: HashMap Full.Name In.Argument
|
||||
-> HashMap Full.Name (Full.Node Transform.Input)
|
||||
-> Either [Full.Location] Type.Subs
|
||||
coerceArgumentValues argumentDefinitions argumentNodes =
|
||||
HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
|
||||
where
|
||||
forEach variableName (In.Argument _ variableType defaultValue) =
|
||||
matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
|
||||
forEach argumentName (In.Argument _ variableType defaultValue) = \case
|
||||
Right resultMap
|
||||
| Just matchedValues
|
||||
<- matchFieldValues' argumentName variableType defaultValue $ Just resultMap
|
||||
-> Right matchedValues
|
||||
| otherwise -> Left $ generateError argumentName []
|
||||
Left errorLocations
|
||||
| Just _
|
||||
<- matchFieldValues' argumentName variableType defaultValue $ pure mempty
|
||||
-> Left errorLocations
|
||||
| otherwise -> Left $ generateError argumentName errorLocations
|
||||
generateError argumentName errorLocations =
|
||||
case HashMap.lookup argumentName argumentNodes of
|
||||
Just (Full.Node _ errorLocation) -> [errorLocation]
|
||||
Nothing -> errorLocations
|
||||
matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes)
|
||||
coerceArgumentValue inputType (Transform.Int integer) =
|
||||
coerceInputLiteral inputType (Type.Int integer)
|
||||
coerceArgumentValue inputType (Transform.Boolean boolean) =
|
||||
|
|
|
@ -0,0 +1,31 @@
|
|||
{- 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 DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Language.GraphQL.Execute.Internal
|
||||
( addError
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State (modify)
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Data.Sequence ((|>))
|
||||
import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..))
|
||||
import Prelude hiding (null)
|
||||
|
||||
addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a
|
||||
addError returnValue error' = modify appender >> pure returnValue
|
||||
where
|
||||
appender :: Resolution m -> Resolution m
|
||||
appender resolution@Resolution{ errors } = resolution
|
||||
{ errors = errors |> error'
|
||||
}
|
||||
|
||||
singleError :: [Full.Location] -> String -> Error
|
||||
singleError errorLocations message = Error (Text.pack message) errorLocations []
|
|
@ -0,0 +1,148 @@
|
|||
{- 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 ExplicitForAll #-}
|
||||
|
||||
-- | This module contains a map data structure, that preserves insertion order.
|
||||
-- Some definitions conflict with functions from prelude, so this module should
|
||||
-- probably be imported qualified.
|
||||
module Language.GraphQL.Execute.OrderedMap
|
||||
( OrderedMap
|
||||
, elems
|
||||
, empty
|
||||
, insert
|
||||
, foldlWithKey'
|
||||
, keys
|
||||
, lookup
|
||||
, replace
|
||||
, singleton
|
||||
, size
|
||||
, toList
|
||||
, traverseMaybe
|
||||
) where
|
||||
|
||||
import qualified Data.Foldable as Foldable
|
||||
import Data.HashMap.Strict (HashMap, (!))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as Vector
|
||||
import Prelude hiding (filter, lookup)
|
||||
|
||||
-- | This map associates values with the given text keys. Insertion order is
|
||||
-- preserved. When inserting a value with a key, that is already available in
|
||||
-- the map, the existing value isn't overridden, but combined with the new value
|
||||
-- using its 'Semigroup' instance.
|
||||
--
|
||||
-- Internally this map uses an array with keys to preserve the order and an
|
||||
-- unorded map with key-value pairs.
|
||||
data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v)
|
||||
deriving (Eq)
|
||||
|
||||
instance Functor OrderedMap where
|
||||
fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap
|
||||
|
||||
instance Foldable OrderedMap where
|
||||
foldr f = foldrWithKey $ const f
|
||||
null (OrderedMap vector _) = Vector.null vector
|
||||
|
||||
instance Semigroup v => Semigroup (OrderedMap v) where
|
||||
(<>) = foldlWithKey'
|
||||
$ \accumulator key value -> insert key value accumulator
|
||||
|
||||
instance Semigroup v => Monoid (OrderedMap v) where
|
||||
mempty = empty
|
||||
|
||||
instance Traversable OrderedMap where
|
||||
traverse f (OrderedMap vector hashMap) = OrderedMap vector
|
||||
<$> traverse f hashMap
|
||||
|
||||
instance Show v => Show (OrderedMap v) where
|
||||
showsPrec precedence map' = showParen (precedence > 10)
|
||||
$ showString "fromList " . shows (toList map')
|
||||
|
||||
-- * Construction
|
||||
|
||||
-- | Constructs a map with a single element.
|
||||
singleton :: forall v. Text -> v -> OrderedMap v
|
||||
singleton key value = OrderedMap (Vector.singleton key)
|
||||
$ HashMap.singleton key value
|
||||
|
||||
-- | Constructs an empty map.
|
||||
empty :: forall v. OrderedMap v
|
||||
empty = OrderedMap mempty mempty
|
||||
|
||||
-- * Traversal
|
||||
|
||||
-- | Reduces this map by applying a binary operator from right to left to all
|
||||
-- elements, using the given starting value.
|
||||
foldrWithKey :: forall v a. (Text -> v -> a -> a) -> a -> OrderedMap v -> a
|
||||
foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector
|
||||
where
|
||||
go key = f key (hashMap ! key)
|
||||
|
||||
-- | Reduces this map by applying a binary operator from left to right to all
|
||||
-- elements, using the given starting value.
|
||||
foldlWithKey' :: forall v a. (a -> Text -> v -> a) -> a -> OrderedMap v -> a
|
||||
foldlWithKey' f initial (OrderedMap vector hashMap) =
|
||||
Vector.foldl' go initial vector
|
||||
where
|
||||
go accumulator key = f accumulator key (hashMap ! key)
|
||||
|
||||
-- | Traverse over the elements and collect the 'Just' results.
|
||||
traverseMaybe
|
||||
:: Applicative f
|
||||
=> forall a
|
||||
. (a -> f (Maybe b))
|
||||
-> OrderedMap a
|
||||
-> f (OrderedMap b)
|
||||
traverseMaybe f orderedMap = foldlWithKey' filter empty
|
||||
<$> traverse f orderedMap
|
||||
where
|
||||
filter accumulator key (Just value) = replace key value accumulator
|
||||
filter accumulator _ Nothing = accumulator
|
||||
|
||||
-- * Lists
|
||||
|
||||
-- | Converts this map to the list of key-value pairs.
|
||||
toList :: forall v. OrderedMap v -> [(Text, v)]
|
||||
toList = foldrWithKey ((.) (:) . (,)) []
|
||||
|
||||
-- | Returns a list with all keys in this map.
|
||||
keys :: forall v. OrderedMap v -> [Text]
|
||||
keys (OrderedMap vector _) = Foldable.toList vector
|
||||
|
||||
-- | Returns a list with all elements in this map.
|
||||
elems :: forall v. OrderedMap v -> [v]
|
||||
elems = fmap snd . toList
|
||||
|
||||
-- * Basic interface
|
||||
|
||||
-- | Associates the specified value with the specified key in this map. If this
|
||||
-- map previously contained a mapping for the key, the existing and new values
|
||||
-- are combined.
|
||||
insert :: Semigroup v => Text -> v -> OrderedMap v -> OrderedMap v
|
||||
insert key value (OrderedMap vector hashMap)
|
||||
| Just available <- HashMap.lookup key hashMap = OrderedMap vector
|
||||
$ HashMap.insert key (available <> value) hashMap
|
||||
| otherwise = OrderedMap (Vector.snoc vector key)
|
||||
$ HashMap.insert key value hashMap
|
||||
|
||||
-- | Associates the specified value with the specified key in this map. If this
|
||||
-- map previously contained a mapping for the key, the existing value is
|
||||
-- replaced by the new one.
|
||||
replace :: Text -> v -> OrderedMap v -> OrderedMap v
|
||||
replace key value (OrderedMap vector hashMap)
|
||||
| HashMap.member key hashMap = OrderedMap vector
|
||||
$ HashMap.insert key value hashMap
|
||||
| otherwise = OrderedMap (Vector.snoc vector key)
|
||||
$ HashMap.insert key value hashMap
|
||||
|
||||
-- | Gives the size of this map, i.e. number of elements in it.
|
||||
size :: forall v. OrderedMap v -> Int
|
||||
size (OrderedMap vector _) = Vector.length vector
|
||||
|
||||
-- | Looks up a value in this map by key.
|
||||
lookup :: forall v. Text -> OrderedMap v -> Maybe v
|
||||
lookup key (OrderedMap _ hashMap) = HashMap.lookup key hashMap
|
|
@ -9,62 +9,78 @@ module Language.GraphQL.Execute.Subscribe
|
|||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Arrow (left)
|
||||
import Control.Monad.Catch (Exception(..), MonadCatch(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Name)
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Execution
|
||||
import Language.GraphQL.Execute.Internal
|
||||
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
|
||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||
import Language.GraphQL.Error
|
||||
( Error(..)
|
||||
, ResolverException
|
||||
, Response
|
||||
, ResponseEventStream
|
||||
, runCollectErrs
|
||||
)
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
subscribe :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
=> HashMap Full.Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Full.Location
|
||||
-> Seq (Transform.Selection m)
|
||||
-> m (Either Text (ResponseEventStream m a))
|
||||
subscribe types' objectType fields = do
|
||||
sourceStream <- createSourceEventStream types' objectType fields
|
||||
traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
|
||||
-> m (Either Error (ResponseEventStream m a))
|
||||
subscribe types' objectType objectLocation fields = do
|
||||
sourceStream <-
|
||||
createSourceEventStream types' objectType objectLocation fields
|
||||
let traverser =
|
||||
mapSourceToResponseEvent types' objectType objectLocation fields
|
||||
traverse traverser sourceStream
|
||||
|
||||
mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
=> HashMap Full.Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Full.Location
|
||||
-> Seq (Transform.Selection m)
|
||||
-> Out.SourceEventStream m
|
||||
-> m (ResponseEventStream m a)
|
||||
mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
|
||||
mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
|
||||
= pure
|
||||
$ sourceStream
|
||||
.| mapMC (executeSubscriptionEvent types' subscriptionType fields)
|
||||
.| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
|
||||
|
||||
createSourceEventStream :: MonadCatch m
|
||||
=> HashMap Name (Type m)
|
||||
=> HashMap Full.Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Full.Location
|
||||
-> Seq (Transform.Selection m)
|
||||
-> m (Either Text (Out.SourceEventStream m))
|
||||
createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
|
||||
| [fieldGroup] <- Map.elems groupedFieldSet
|
||||
, Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
|
||||
-> m (Either Error (Out.SourceEventStream m))
|
||||
createSourceEventStream _types subscriptionType objectLocation fields
|
||||
| [fieldGroup] <- OrderedMap.elems groupedFieldSet
|
||||
, Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
|
||||
, Out.ObjectType _ _ _ fieldTypes <- subscriptionType
|
||||
, resolverT <- fieldTypes HashMap.! fieldName
|
||||
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
|
||||
, Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
|
||||
case coerceArgumentValues argumentDefinitions arguments' of
|
||||
Nothing -> pure $ Left "Argument coercion failed."
|
||||
Just argumentValues ->
|
||||
resolveFieldEventStream Type.Null argumentValues resolver
|
||||
| otherwise = pure $ Left "Subscription contains more than one field."
|
||||
Left _ -> pure
|
||||
$ Left
|
||||
$ Error "Argument coercion failed." [errorLocation] []
|
||||
Right argumentValues -> left (singleError [errorLocation])
|
||||
<$> resolveFieldEventStream Type.Null argumentValues resolver
|
||||
| otherwise = pure
|
||||
$ Left
|
||||
$ Error "Subscription contains more than one field." [objectLocation] []
|
||||
where
|
||||
groupedFieldSet = collectFields subscriptionType fields
|
||||
|
||||
|
@ -72,26 +88,26 @@ resolveFieldEventStream :: MonadCatch m
|
|||
=> Type.Value
|
||||
-> Type.Subs
|
||||
-> Out.Subscribe m
|
||||
-> m (Either Text (Out.SourceEventStream m))
|
||||
-> m (Either String (Out.SourceEventStream m))
|
||||
resolveFieldEventStream result args resolver =
|
||||
catch (Right <$> runReaderT resolver context) handleEventStreamError
|
||||
where
|
||||
handleEventStreamError :: MonadCatch m
|
||||
=> ResolverException
|
||||
-> m (Either Text (Out.SourceEventStream m))
|
||||
handleEventStreamError = pure . Left . Text.pack . displayException
|
||||
-> m (Either String (Out.SourceEventStream m))
|
||||
handleEventStreamError = pure . Left . displayException
|
||||
context = Type.Context
|
||||
{ Type.arguments = Type.Arguments args
|
||||
, Type.values = result
|
||||
}
|
||||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
=> HashMap Full.Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Full.Location
|
||||
-> Seq (Transform.Selection m)
|
||||
-> Definition.Value
|
||||
-> m (Response a)
|
||||
executeSubscriptionEvent types' objectType fields initialValue =
|
||||
runCollectErrs types' $ executeSelectionSet initialValue objectType fields
|
||||
executeSubscriptionEvent types' objectType objectLocation fields initialValue
|
||||
= runCollectErrs types'
|
||||
$ executeSelectionSet initialValue objectType objectLocation fields
|
||||
|
|
|
@ -1,3 +1,7 @@
|
|||
{- 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 ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
@ -25,7 +29,6 @@ module Language.GraphQL.Execute.Transform
|
|||
, QueryError(..)
|
||||
, Selection(..)
|
||||
, document
|
||||
, queryError
|
||||
) where
|
||||
|
||||
import Control.Monad (foldM, unless)
|
||||
|
@ -71,16 +74,18 @@ data Selection m
|
|||
| SelectionField (Field m)
|
||||
|
||||
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
||||
--
|
||||
-- Currently only queries and mutations are supported.
|
||||
data Operation m
|
||||
= Query (Maybe Text) (Seq (Selection m))
|
||||
| Mutation (Maybe Text) (Seq (Selection m))
|
||||
| Subscription (Maybe Text) (Seq (Selection m))
|
||||
= Query (Maybe Text) (Seq (Selection m)) Full.Location
|
||||
| Mutation (Maybe Text) (Seq (Selection m)) Full.Location
|
||||
| Subscription (Maybe Text) (Seq (Selection m)) Full.Location
|
||||
|
||||
-- | Single GraphQL field.
|
||||
data Field m = Field
|
||||
(Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
|
||||
(Maybe Full.Name)
|
||||
Full.Name
|
||||
(HashMap Full.Name (Full.Node Input))
|
||||
(Seq (Selection m))
|
||||
Full.Location
|
||||
|
||||
-- | Contains the operation to be executed along with its root type.
|
||||
data Document m = Document
|
||||
|
@ -92,16 +97,26 @@ data OperationDefinition = OperationDefinition
|
|||
[Full.VariableDefinition]
|
||||
[Full.Directive]
|
||||
Full.SelectionSet
|
||||
Full.Location
|
||||
|
||||
-- | Query error types.
|
||||
data QueryError
|
||||
= OperationNotFound Text
|
||||
| OperationNameRequired
|
||||
| CoercionError
|
||||
| TransformationError
|
||||
| EmptyDocument
|
||||
| UnsupportedRootOperation
|
||||
|
||||
instance Show QueryError where
|
||||
show (OperationNotFound operationName) = unwords
|
||||
["Operation", Text.unpack operationName, "couldn't be found in the document."]
|
||||
show OperationNameRequired = "Missing operation name."
|
||||
show CoercionError = "Coercion error."
|
||||
show EmptyDocument =
|
||||
"The document doesn't contain any executable operations."
|
||||
show UnsupportedRootOperation =
|
||||
"Root operation type couldn't be found in the schema."
|
||||
|
||||
data Input
|
||||
= Int Int32
|
||||
| Float Double
|
||||
|
@ -114,17 +129,6 @@ data Input
|
|||
| Variable Type.Value
|
||||
deriving (Eq, Show)
|
||||
|
||||
queryError :: QueryError -> Text
|
||||
queryError (OperationNotFound operationName) = Text.unwords
|
||||
["Operation", operationName, "couldn't be found in the document."]
|
||||
queryError OperationNameRequired = "Missing operation name."
|
||||
queryError CoercionError = "Coercion error."
|
||||
queryError TransformationError = "Schema transformation error."
|
||||
queryError EmptyDocument =
|
||||
"The document doesn't contain any executable operations."
|
||||
queryError UnsupportedRootOperation =
|
||||
"Root operation type couldn't be found in the schema."
|
||||
|
||||
getOperation
|
||||
:: Maybe Full.Name
|
||||
-> NonEmpty OperationDefinition
|
||||
|
@ -135,7 +139,7 @@ getOperation (Just operationName) operations
|
|||
| Just operation' <- find matchingName operations = pure operation'
|
||||
| otherwise = Left $ OperationNotFound operationName
|
||||
where
|
||||
matchingName (OperationDefinition _ name _ _ _) =
|
||||
matchingName (OperationDefinition _ name _ _ _ _) =
|
||||
name == Just operationName
|
||||
|
||||
coerceVariableValues :: Coerce.VariableValue a
|
||||
|
@ -145,7 +149,7 @@ coerceVariableValues :: Coerce.VariableValue a
|
|||
-> HashMap.HashMap Full.Name a
|
||||
-> Either QueryError Type.Subs
|
||||
coerceVariableValues types operationDefinition variableValues =
|
||||
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
|
||||
let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
|
||||
in maybe (Left CoercionError) Right
|
||||
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
||||
where
|
||||
|
@ -173,7 +177,7 @@ constValue (Full.ConstString x) = Type.String x
|
|||
constValue (Full.ConstBoolean b) = Type.Boolean b
|
||||
constValue Full.ConstNull = Type.Null
|
||||
constValue (Full.ConstEnum e) = Type.Enum e
|
||||
constValue (Full.ConstList l) = Type.List $ constValue <$> l
|
||||
constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
|
||||
constValue (Full.ConstObject o) =
|
||||
Type.Object $ HashMap.fromList $ constObjectField <$> o
|
||||
where
|
||||
|
@ -203,14 +207,14 @@ document schema operationName subs ast = do
|
|||
, types = referencedTypes
|
||||
}
|
||||
case chosenOperation of
|
||||
OperationDefinition Full.Query _ _ _ _ ->
|
||||
OperationDefinition Full.Query _ _ _ _ _ ->
|
||||
pure $ Document referencedTypes (Schema.query schema)
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Mutation _ _ _ _
|
||||
OperationDefinition Full.Mutation _ _ _ _ _
|
||||
| Just mutationType <- Schema.mutation schema ->
|
||||
pure $ Document referencedTypes mutationType
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Subscription _ _ _ _
|
||||
OperationDefinition Full.Subscription _ _ _ _ _
|
||||
| Just subscriptionType <- Schema.subscription schema ->
|
||||
pure $ Document referencedTypes subscriptionType
|
||||
$ operation chosenOperation replacement
|
||||
|
@ -235,10 +239,10 @@ defragment ast =
|
|||
(operations, HashMap.insert name fragment fragments')
|
||||
defragment' _ acc = acc
|
||||
transform = \case
|
||||
Full.OperationDefinition type' name variables directives' selections _ ->
|
||||
OperationDefinition type' name variables directives' selections
|
||||
Full.SelectionSet selectionSet _ ->
|
||||
OperationDefinition Full.Query Nothing mempty mempty selectionSet
|
||||
Full.OperationDefinition type' name variables directives' selections location ->
|
||||
OperationDefinition type' name variables directives' selections location
|
||||
Full.SelectionSet selectionSet location ->
|
||||
OperationDefinition Full.Query Nothing mempty mempty selectionSet location
|
||||
|
||||
-- * Operation
|
||||
|
||||
|
@ -247,12 +251,12 @@ operation operationDefinition replacement
|
|||
= runIdentity
|
||||
$ evalStateT (collectFragments >> transform operationDefinition) replacement
|
||||
where
|
||||
transform (OperationDefinition Full.Query name _ _ sels) =
|
||||
Query name <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Mutation name _ _ sels) =
|
||||
Mutation name <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Subscription name _ _ sels) =
|
||||
Subscription name <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Query name _ _ sels location) =
|
||||
flip (Query name) location <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Mutation name _ _ sels location) =
|
||||
flip (Mutation name) location <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Subscription name _ _ sels location) =
|
||||
flip (Subscription name) location <$> appendSelection sels
|
||||
|
||||
-- * Selection
|
||||
|
||||
|
@ -268,15 +272,20 @@ selection (Full.InlineFragmentSelection fragmentSelection) =
|
|||
inlineFragment fragmentSelection
|
||||
|
||||
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
|
||||
field (Full.Field alias name arguments' directives' selections _) = do
|
||||
field (Full.Field alias name arguments' directives' selections location) = do
|
||||
fieldArguments <- foldM go HashMap.empty arguments'
|
||||
fieldSelections <- appendSelection selections
|
||||
fieldDirectives <- Definition.selection <$> directives directives'
|
||||
let field' = Field alias name fieldArguments fieldSelections
|
||||
let field' = Field alias name fieldArguments fieldSelections location
|
||||
pure $ field' <$ fieldDirectives
|
||||
where
|
||||
go arguments (Full.Argument name' (Full.Node value' _) _) =
|
||||
inputField arguments name' value'
|
||||
go arguments (Full.Argument name' (Full.Node value' _) location') = do
|
||||
objectFieldValue <- input value'
|
||||
case objectFieldValue of
|
||||
Just fieldValue ->
|
||||
let argumentNode = Full.Node fieldValue location'
|
||||
in pure $ HashMap.insert name' argumentNode arguments
|
||||
Nothing -> pure arguments
|
||||
|
||||
fragmentSpread
|
||||
:: Full.FragmentSpread
|
||||
|
@ -380,7 +389,7 @@ value (Full.String string) = pure $ Type.String string
|
|||
value (Full.Boolean boolean) = pure $ Type.Boolean boolean
|
||||
value Full.Null = pure Type.Null
|
||||
value (Full.Enum enum) = pure $ Type.Enum enum
|
||||
value (Full.List list) = Type.List <$> traverse value list
|
||||
value (Full.List list) = Type.List <$> traverse (value . Full.node) list
|
||||
value (Full.Object object) =
|
||||
Type.Object . HashMap.fromList <$> traverse objectField object
|
||||
where
|
||||
|
@ -396,7 +405,7 @@ input (Full.String string) = pure $ pure $ String string
|
|||
input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
|
||||
input Full.Null = pure $ pure Null
|
||||
input (Full.Enum enum) = pure $ pure $ Enum enum
|
||||
input (Full.List list) = pure . List <$> traverse value list
|
||||
input (Full.List list) = pure . List <$> traverse (value . Full.node) list
|
||||
input (Full.Object object) = do
|
||||
objectFields <- foldM objectField HashMap.empty object
|
||||
pure $ pure $ Object objectFields
|
||||
|
|
|
@ -21,6 +21,6 @@ module Language.GraphQL.Type
|
|||
) where
|
||||
|
||||
import Language.GraphQL.Type.Definition
|
||||
import Language.GraphQL.Type.Schema (Schema, schema)
|
||||
import Language.GraphQL.Type.Schema (Schema, schema, schemaWithTypes)
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
|
|
@ -12,6 +12,7 @@ module Language.GraphQL.Type.Internal
|
|||
, Directives
|
||||
, Schema(..)
|
||||
, Type(..)
|
||||
, description
|
||||
, directives
|
||||
, doesFragmentTypeApply
|
||||
, implementations
|
||||
|
@ -55,41 +56,43 @@ type Directives = HashMap Full.Name Directive
|
|||
-- | A Schema is created by supplying the root types of each type of operation,
|
||||
-- query and mutation (optional). A schema definition is then supplied to the
|
||||
-- validator and executor.
|
||||
--
|
||||
-- __Note:__ When the schema is constructed, by default only the types that
|
||||
-- are reachable by traversing the root types are included, other types must
|
||||
-- be explicitly referenced.
|
||||
data Schema m = Schema
|
||||
(Out.ObjectType m)
|
||||
(Maybe (Out.ObjectType m))
|
||||
(Maybe (Out.ObjectType m))
|
||||
Directives
|
||||
(HashMap Full.Name (Type m))
|
||||
(Maybe Text) -- ^ Description.
|
||||
(Out.ObjectType m) -- ^ Query.
|
||||
(Maybe (Out.ObjectType m)) -- ^ Mutation.
|
||||
(Maybe (Out.ObjectType m)) -- ^ Subscription.
|
||||
Directives -- ^ Directives
|
||||
(HashMap Full.Name (Type m)) -- ^ Types.
|
||||
-- Interface implementations (used only for faster access).
|
||||
(HashMap Full.Name [Type m])
|
||||
|
||||
-- | Schema description.
|
||||
description :: forall m. Schema m -> Maybe Text
|
||||
description (Schema description' _ _ _ _ _ _) = description'
|
||||
|
||||
-- | Schema query type.
|
||||
query :: forall m. Schema m -> Out.ObjectType m
|
||||
query (Schema query' _ _ _ _ _) = query'
|
||||
query (Schema _ query' _ _ _ _ _) = query'
|
||||
|
||||
-- | Schema mutation type.
|
||||
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||
mutation (Schema _ mutation' _ _ _ _) = mutation'
|
||||
mutation (Schema _ _ mutation' _ _ _ _) = mutation'
|
||||
|
||||
-- | Schema subscription type.
|
||||
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
|
||||
subscription (Schema _ _ subscription' _ _ _) = subscription'
|
||||
subscription (Schema _ _ _ subscription' _ _ _) = subscription'
|
||||
|
||||
-- | Schema directive definitions.
|
||||
directives :: forall m. Schema m -> Directives
|
||||
directives (Schema _ _ _ directives' _ _) = directives'
|
||||
directives (Schema _ _ _ _ directives' _ _) = directives'
|
||||
|
||||
-- | Types referenced by the schema.
|
||||
types :: forall m. Schema m -> HashMap Full.Name (Type m)
|
||||
types (Schema _ _ _ _ types' _) = types'
|
||||
types (Schema _ _ _ _ _ types' _) = types'
|
||||
|
||||
-- | Interface implementations.
|
||||
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
|
||||
implementations (Schema _ _ _ _ _ implementations') = implementations'
|
||||
implementations (Schema _ _ _ _ _ _ implementations') = implementations'
|
||||
|
||||
-- | These types may describe the parent context of a selection set.
|
||||
data CompositeType m
|
||||
|
|
|
@ -9,11 +9,13 @@
|
|||
-- functions for defining and manipulating schemas.
|
||||
module Language.GraphQL.Type.Schema
|
||||
( schema
|
||||
, schemaWithTypes
|
||||
, module Language.GraphQL.Type.Internal
|
||||
) where
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
|
@ -22,6 +24,7 @@ import Language.GraphQL.Type.Internal
|
|||
, Directives
|
||||
, Schema
|
||||
, Type(..)
|
||||
, description
|
||||
, directives
|
||||
, implementations
|
||||
, mutation
|
||||
|
@ -35,17 +38,47 @@ import qualified Language.GraphQL.Type.In as In
|
|||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
-- | Schema constructor.
|
||||
--
|
||||
-- __Note:__ When the schema is constructed, by default only the types that
|
||||
-- are reachable by traversing the root types are included, other types must
|
||||
-- be explicitly referenced using 'schemaWithTypes' instead.
|
||||
schema :: forall m
|
||||
. Out.ObjectType m -- ^ Query type.
|
||||
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
||||
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
||||
-> Directives -- ^ Directive definitions.
|
||||
-> Schema m -- ^ Schema.
|
||||
schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
|
||||
Internal.Schema queryRoot mutationRoot subscriptionRoot
|
||||
schema queryRoot mutationRoot subscriptionRoot =
|
||||
schemaWithTypes Nothing queryRoot mutationRoot subscriptionRoot mempty
|
||||
|
||||
-- | Constructs a complete schema, including user-defined types not referenced
|
||||
-- in the schema directly (for example interface implementations).
|
||||
schemaWithTypes :: forall m
|
||||
. Maybe Text -- ^ Schema description
|
||||
-> Out.ObjectType m -- ^ Query type.
|
||||
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
|
||||
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
|
||||
-> [Type m] -- ^ Additional types.
|
||||
-> Directives -- ^ Directive definitions.
|
||||
-> Schema m -- ^ Schema.
|
||||
schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' directiveDefinitions =
|
||||
Internal.Schema description' queryRoot mutationRoot subscriptionRoot
|
||||
allDirectives collectedTypes collectedImplementations
|
||||
where
|
||||
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
|
||||
allTypes = foldr addTypeDefinition HashMap.empty types'
|
||||
addTypeDefinition type'@(ScalarType (Definition.ScalarType typeName _)) accumulator =
|
||||
HashMap.insert typeName type' accumulator
|
||||
addTypeDefinition type'@(EnumType (Definition.EnumType typeName _ _)) accumulator =
|
||||
HashMap.insert typeName type' accumulator
|
||||
addTypeDefinition type'@(ObjectType (Out.ObjectType typeName _ _ _)) accumulator =
|
||||
HashMap.insert typeName type' accumulator
|
||||
addTypeDefinition type'@(InputObjectType (In.InputObjectType typeName _ _)) accumulator =
|
||||
HashMap.insert typeName type' accumulator
|
||||
addTypeDefinition type'@(InterfaceType (Out.InterfaceType typeName _ _ _)) accumulator =
|
||||
HashMap.insert typeName type' accumulator
|
||||
addTypeDefinition type'@(UnionType (Out.UnionType typeName _ _)) accumulator =
|
||||
HashMap.insert typeName type' accumulator
|
||||
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot allTypes
|
||||
collectedImplementations = collectImplementations collectedTypes
|
||||
allDirectives = HashMap.union directiveDefinitions defaultDirectives
|
||||
defaultDirectives = HashMap.fromList
|
||||
|
@ -98,11 +131,12 @@ collectReferencedTypes :: forall m
|
|||
-> Maybe (Out.ObjectType m)
|
||||
-> Maybe (Out.ObjectType m)
|
||||
-> HashMap Full.Name (Type m)
|
||||
collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
|
||||
let queryTypes = traverseObjectType queryRoot HashMap.empty
|
||||
-> HashMap Full.Name (Type m)
|
||||
collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes =
|
||||
let queryTypes = traverseObjectType queryRoot extraTypes
|
||||
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
|
||||
mutationRoot
|
||||
in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
|
||||
in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot
|
||||
where
|
||||
collect traverser typeName element foundTypes
|
||||
| HashMap.member typeName foundTypes = foundTypes
|
||||
|
|
|
@ -4,7 +4,6 @@
|
|||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | GraphQL validator.
|
||||
|
@ -315,9 +314,6 @@ constValue (Validation.ValueRule _ rule) valueType = go valueType
|
|||
go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
|
||||
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|
||||
|> rule inputObjectType value'
|
||||
go listType value'@(Full.Node (Full.ConstList values) location')
|
||||
= embedListLocation go listType values location'
|
||||
|> rule listType value'
|
||||
go anotherValue value' = pure $ rule anotherValue value'
|
||||
forEach inputObjectType Full.ObjectField{value = value', ..} =
|
||||
go (valueTypeByName name inputObjectType) value'
|
||||
|
@ -421,20 +417,6 @@ argument rule argumentType (Full.Argument _ value' _) =
|
|||
where
|
||||
valueType (In.Argument _ valueType' _) = valueType'
|
||||
|
||||
-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
|
||||
embedListLocation :: forall a m
|
||||
. (Maybe In.Type -> Full.Node a -> Seq m)
|
||||
-> Maybe In.Type
|
||||
-> [a]
|
||||
-> Full.Location
|
||||
-> Seq m
|
||||
embedListLocation go listType values location'
|
||||
= foldMap (go $ valueTypeFromList listType)
|
||||
$ flip Full.Node location' <$> Seq.fromList values
|
||||
where
|
||||
valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
|
||||
valueTypeFromList _ = Nothing
|
||||
|
||||
value :: forall m
|
||||
. Validation.Rule m
|
||||
-> Maybe In.Type
|
||||
|
@ -445,9 +427,6 @@ value (Validation.ValueRule rule _) valueType = go valueType
|
|||
go inputObjectType value'@(Full.Node (Full.Object fields) _)
|
||||
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|
||||
|> rule inputObjectType value'
|
||||
go listType value'@(Full.Node (Full.List values) location')
|
||||
= embedListLocation go listType values location'
|
||||
|> rule listType value'
|
||||
go anotherValue value' = pure $ rule anotherValue value'
|
||||
forEach inputObjectType Full.ObjectField{value = value', ..} =
|
||||
go (valueTypeByName name inputObjectType) value'
|
||||
|
|
|
@ -1502,15 +1502,6 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
|||
hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False
|
||||
hasNonNullVariableDefaultValue Nothing = False
|
||||
hasNonNullVariableDefaultValue _ = True
|
||||
unwrapInType (In.NonNullScalarType nonNullType) =
|
||||
Just $ In.NamedScalarType nonNullType
|
||||
unwrapInType (In.NonNullEnumType nonNullType) =
|
||||
Just $ In.NamedEnumType nonNullType
|
||||
unwrapInType (In.NonNullInputObjectType nonNullType) =
|
||||
Just $ In.NamedInputObjectType nonNullType
|
||||
unwrapInType (In.NonNullListType nonNullType) =
|
||||
Just $ In.ListType nonNullType
|
||||
unwrapInType _ = Nothing
|
||||
makeError variableDefinition expectedType =
|
||||
let Full.VariableDefinition variableName variableType _ location' =
|
||||
variableDefinition
|
||||
|
@ -1527,6 +1518,17 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
|||
, locations = [location']
|
||||
}
|
||||
|
||||
unwrapInType :: In.Type -> Maybe In.Type
|
||||
unwrapInType (In.NonNullScalarType nonNullType) =
|
||||
Just $ In.NamedScalarType nonNullType
|
||||
unwrapInType (In.NonNullEnumType nonNullType) =
|
||||
Just $ In.NamedEnumType nonNullType
|
||||
unwrapInType (In.NonNullInputObjectType nonNullType) =
|
||||
Just $ In.NamedInputObjectType nonNullType
|
||||
unwrapInType (In.NonNullListType nonNullType) =
|
||||
Just $ In.ListType nonNullType
|
||||
unwrapInType _ = Nothing
|
||||
|
||||
-- | Literal values must be compatible with the type expected in the position
|
||||
-- they are found as per the coercion rules.
|
||||
--
|
||||
|
@ -1540,7 +1542,7 @@ valuesOfCorrectTypeRule = ValueRule go constGo
|
|||
go (Just inputType) value
|
||||
| Just constValue <- toConstNode value =
|
||||
lift $ check inputType constValue
|
||||
go _ _ = lift mempty
|
||||
go _ _ = lift mempty -- This rule checks only literals.
|
||||
toConstNode Full.Node{..} = flip Full.Node location <$> toConst node
|
||||
toConst (Full.Variable _) = Nothing
|
||||
toConst (Full.Int integer) = Just $ Full.ConstInt integer
|
||||
|
@ -1550,7 +1552,7 @@ 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 $ toConst <$> values
|
||||
Just $ Full.ConstList $ catMaybes $ toConstNode <$> values
|
||||
toConst (Full.Object fields) = Just $ Full.ConstObject
|
||||
$ catMaybes $ constObjectField <$> fields
|
||||
constObjectField Full.ObjectField{..}
|
||||
|
@ -1582,24 +1584,37 @@ valuesOfCorrectTypeRule = ValueRule go constGo
|
|||
, Full.ConstEnum memberValue <- node
|
||||
, HashMap.member memberValue members = mempty
|
||||
check (In.InputObjectBaseType objectType) Full.Node{ node }
|
||||
| In.InputObjectType _ _ typeFields <- objectType
|
||||
, Full.ConstObject valueFields <- node =
|
||||
foldMap (checkObjectField typeFields) valueFields
|
||||
-- Skip, objects are checked recursively by the validation traverser.
|
||||
| In.InputObjectType{} <- objectType
|
||||
, Full.ConstObject{} <- node = mempty
|
||||
check (In.ListBaseType listType) constValue@Full.Node{ .. }
|
||||
| Full.ConstList listValues <- node =
|
||||
foldMap (check listType) $ flip Full.Node location <$> listValues
|
||||
| Full.ConstList values <- node =
|
||||
foldMap (checkNull listType) values
|
||||
| otherwise = check listType constValue
|
||||
check inputType Full.Node{ .. } = pure $ Error
|
||||
{ message = concat
|
||||
[ "Value "
|
||||
, show node, " cannot be coerced to type \""
|
||||
, show node
|
||||
, " cannot be coerced to type \""
|
||||
, show inputType
|
||||
, "\"."
|
||||
]
|
||||
, locations = [location]
|
||||
}
|
||||
checkObjectField typeFields Full.ObjectField{..}
|
||||
| Just typeField <- HashMap.lookup name typeFields
|
||||
, In.InputField _ fieldType _ <- typeField =
|
||||
check fieldType value
|
||||
checkObjectField _ _ = mempty
|
||||
checkNull inputType constValue =
|
||||
let checkResult = check inputType constValue
|
||||
in case null checkResult of
|
||||
True
|
||||
| Just unwrappedType <- unwrapInType inputType
|
||||
, Full.Node{ node = Full.ConstNull, .. } <- constValue ->
|
||||
pure $ Error
|
||||
{ message = concat
|
||||
[ "List of non-null values of type \""
|
||||
, show unwrappedType
|
||||
, "\" cannot contain null values."
|
||||
]
|
||||
, locations = [location]
|
||||
}
|
||||
| otherwise -> mempty
|
||||
_ -> checkResult
|
||||
|
||||
|
|
|
@ -1,9 +0,0 @@
|
|||
resolver: lts-17.2
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
||||
extra-deps: []
|
||||
flags: {}
|
||||
|
||||
pvp-bounds: lower
|
|
@ -6,6 +6,7 @@ module Language.GraphQL.AST.ParserSpec
|
|||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
|
@ -119,6 +120,56 @@ spec = describe "Parser" $ do
|
|||
| FRAGMENT_SPREAD
|
||||
|]
|
||||
|
||||
it "parses two minimal directive definitions" $
|
||||
let directive nm loc =
|
||||
TypeSystemDefinition
|
||||
(DirectiveDefinition
|
||||
(Description Nothing)
|
||||
nm
|
||||
(ArgumentsDefinition [])
|
||||
(loc :| []))
|
||||
example1 =
|
||||
directive "example1"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
(Location {line = 2, column = 17})
|
||||
example2 =
|
||||
directive "example2"
|
||||
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
||||
(Location {line = 3, column = 17})
|
||||
testSchemaExtension = example1 :| [ example2 ]
|
||||
query = [r|
|
||||
directive @example1 on FIELD_DEFINITION
|
||||
directive @example2 on FIELD
|
||||
|]
|
||||
in parse document "" query `shouldParse` testSchemaExtension
|
||||
|
||||
it "parses a directive definition with a default empty list argument" $
|
||||
let directive nm loc args =
|
||||
TypeSystemDefinition
|
||||
(DirectiveDefinition
|
||||
(Description Nothing)
|
||||
nm
|
||||
(ArgumentsDefinition
|
||||
[ InputValueDefinition
|
||||
(Description Nothing)
|
||||
argName
|
||||
argType
|
||||
argValue
|
||||
[]
|
||||
| (argName, argType, argValue) <- args])
|
||||
(loc :| []))
|
||||
defn =
|
||||
directive "test"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
[("foo",
|
||||
TypeList (TypeNamed "String"),
|
||||
Just
|
||||
$ Node (ConstList [])
|
||||
$ Location {line = 1, column = 33})]
|
||||
(Location {line = 1, column = 1})
|
||||
query = [r|directive @test(foo: [String] = []) on FIELD_DEFINITION|]
|
||||
in parse document "" query `shouldParse` (defn :| [ ])
|
||||
|
||||
it "parses schema extension with a new directive" $
|
||||
parse document "" `shouldSucceedOn`[r|
|
||||
extend schema @newDirective
|
||||
|
|
|
@ -8,17 +8,29 @@ module Language.GraphQL.ErrorSpec
|
|||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Language.GraphQL.Error
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
)
|
||||
import Test.Hspec
|
||||
( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
)
|
||||
import Text.Megaparsec (PosState(..))
|
||||
import Text.Megaparsec.Error (ParseError(..), ParseErrorBundle(..))
|
||||
import Text.Megaparsec.Pos (SourcePos(..), mkPos)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "singleError" $
|
||||
it "constructs an error with the given message" $
|
||||
let errors'' = Seq.singleton $ Error "Message." [] []
|
||||
expected = Response Aeson.Null errors''
|
||||
in singleError "Message." `shouldBe` expected
|
||||
spec = describe "parseError" $
|
||||
it "generates response with a single error" $ do
|
||||
let parseErrors = TrivialError 0 Nothing mempty :| []
|
||||
posState = PosState
|
||||
{ pstateInput = ""
|
||||
, pstateOffset = 0
|
||||
, pstateSourcePos = SourcePos "" (mkPos 1) (mkPos 1)
|
||||
, pstateTabWidth = mkPos 1
|
||||
, pstateLinePrefix = ""
|
||||
}
|
||||
Response Aeson.Null actual <-
|
||||
parseError (ParseErrorBundle parseErrors posState)
|
||||
length actual `shouldBe` 1
|
||||
|
|
|
@ -0,0 +1,72 @@
|
|||
{- 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 Language.GraphQL.Execute.OrderedMapSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
|
||||
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "OrderedMap" $ do
|
||||
it "creates an empty map" $
|
||||
(mempty :: OrderedMap String) `shouldSatisfy` null
|
||||
|
||||
it "creates a singleton" $
|
||||
let value :: String
|
||||
value = "value"
|
||||
in OrderedMap.size (OrderedMap.singleton "key" value) `shouldBe` 1
|
||||
|
||||
it "combines inserted vales" $
|
||||
let key = "key"
|
||||
map1 = OrderedMap.singleton key ("1" :: String)
|
||||
map2 = OrderedMap.singleton key ("2" :: String)
|
||||
in OrderedMap.lookup key (map1 <> map2) `shouldBe` Just "12"
|
||||
|
||||
it "shows the map" $
|
||||
let actual = show
|
||||
$ OrderedMap.insert "key1" "1"
|
||||
$ OrderedMap.singleton "key2" ("2" :: String)
|
||||
expected = "fromList [(\"key2\",\"2\"),(\"key1\",\"1\")]"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "traverses a map of just values" $
|
||||
let actual = sequence
|
||||
$ OrderedMap.insert "key1" (Just "2")
|
||||
$ OrderedMap.singleton "key2" $ Just ("1" :: String)
|
||||
expected = Just
|
||||
$ OrderedMap.insert "key1" "2"
|
||||
$ OrderedMap.singleton "key2" ("1" :: String)
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "traverses a map with a Nothing" $
|
||||
let actual = sequence
|
||||
$ OrderedMap.insert "key1" Nothing
|
||||
$ OrderedMap.singleton "key2" $ Just ("1" :: String)
|
||||
expected = Nothing
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "combines two maps preserving the order of the second one" $
|
||||
let map1 :: OrderedMap String
|
||||
map1 = OrderedMap.insert "key2" "2"
|
||||
$ OrderedMap.singleton "key1" "1"
|
||||
map2 :: OrderedMap String
|
||||
map2 = OrderedMap.insert "key4" "4"
|
||||
$ OrderedMap.singleton "key3" "3"
|
||||
expected = OrderedMap.insert "key4" "4"
|
||||
$ OrderedMap.insert "key3" "3"
|
||||
$ OrderedMap.insert "key2" "2"
|
||||
$ OrderedMap.singleton "key1" "1"
|
||||
in (map1 <> map2) `shouldBe` expected
|
||||
|
||||
it "replaces existing values" $
|
||||
let key = "key"
|
||||
actual = OrderedMap.replace key ("2" :: String)
|
||||
$ OrderedMap.singleton key ("1" :: String)
|
||||
in OrderedMap.lookup key actual `shouldBe` Just "2"
|
|
@ -8,34 +8,87 @@ module Language.GraphQL.ExecuteSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Control.Exception (SomeException)
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson.Types (emptyObject)
|
||||
import Data.Conduit
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL.AST (Document, Name)
|
||||
import Data.Typeable (cast)
|
||||
import Language.GraphQL.AST (Document, Location(..), Name)
|
||||
import Language.GraphQL.AST.Parser (document)
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Execute (execute)
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
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.RawString.QQ (r)
|
||||
|
||||
data PhilosopherException = PhilosopherException
|
||||
deriving Show
|
||||
|
||||
instance Exception PhilosopherException where
|
||||
toException = toException. ResolverException
|
||||
fromException e = do
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
philosopherSchema :: Schema (Either SomeException)
|
||||
philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty
|
||||
philosopherSchema =
|
||||
schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
|
||||
where
|
||||
subscriptionRoot = Just subscriptionType
|
||||
extraTypes =
|
||||
[ Schema.ObjectType bookType
|
||||
, Schema.ObjectType bookCollectionType
|
||||
]
|
||||
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "philosopher"
|
||||
$ ValueResolver philosopherField
|
||||
$ pure $ Type.Object mempty
|
||||
$ HashMap.fromList
|
||||
[ ("philosopher", ValueResolver philosopherField philosopherResolver)
|
||||
, ("genres", ValueResolver genresField genresResolver)
|
||||
]
|
||||
where
|
||||
philosopherField =
|
||||
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
||||
Out.Field Nothing (Out.NonNullObjectType philosopherType)
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NamedScalarType id) Nothing
|
||||
philosopherResolver = pure $ Object mempty
|
||||
genresField =
|
||||
let fieldType = Out.ListType $ Out.NonNullScalarType string
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
genresResolver :: Resolve (Either SomeException)
|
||||
genresResolver = throwM PhilosopherException
|
||||
|
||||
musicType :: Out.ObjectType (Either SomeException)
|
||||
musicType = Out.ObjectType "Music" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("instrument", ValueResolver instrumentField instrumentResolver)
|
||||
]
|
||||
instrumentResolver = pure $ String "piano"
|
||||
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
poetryType :: Out.ObjectType (Either SomeException)
|
||||
poetryType = Out.ObjectType "Poetry" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("genre", ValueResolver genreField genreResolver)
|
||||
]
|
||||
genreResolver = pure $ String "Futurism"
|
||||
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
interestType :: Out.UnionType (Either SomeException)
|
||||
interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
|
||||
|
||||
philosopherType :: Out.ObjectType (Either SomeException)
|
||||
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
|
@ -44,19 +97,68 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
|
|||
resolvers =
|
||||
[ ("firstName", ValueResolver firstNameField firstNameResolver)
|
||||
, ("lastName", ValueResolver lastNameField lastNameResolver)
|
||||
, ("school", ValueResolver schoolField schoolResolver)
|
||||
, ("interest", ValueResolver interestField interestResolver)
|
||||
, ("majorWork", ValueResolver majorWorkField majorWorkResolver)
|
||||
, ("century", ValueResolver centuryField centuryResolver)
|
||||
]
|
||||
firstNameField =
|
||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
firstNameResolver = pure $ Type.String "Friedrich"
|
||||
firstNameResolver = pure $ String "Friedrich"
|
||||
lastNameField
|
||||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
lastNameResolver = pure $ Type.String "Nietzsche"
|
||||
lastNameResolver = pure $ String "Nietzsche"
|
||||
schoolField
|
||||
= Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty
|
||||
schoolResolver = pure $ Enum "EXISTENTIALISM"
|
||||
interestField
|
||||
= Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty
|
||||
interestResolver = pure
|
||||
$ Object
|
||||
$ HashMap.fromList [("instrument", "piano")]
|
||||
majorWorkField
|
||||
= Out.Field Nothing (Out.NonNullInterfaceType workType) HashMap.empty
|
||||
majorWorkResolver = pure
|
||||
$ Object
|
||||
$ HashMap.fromList
|
||||
[ ("title", "Also sprach Zarathustra: Ein Buch für Alle und Keinen")
|
||||
]
|
||||
centuryField =
|
||||
Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty
|
||||
centuryResolver = pure $ Float 18.5
|
||||
|
||||
workType :: Out.InterfaceType (Either SomeException)
|
||||
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 "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("title", ValueResolver titleField titleResolver)
|
||||
]
|
||||
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 "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("title", ValueResolver titleField titleResolver)
|
||||
]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "The Three Critiques"
|
||||
|
||||
subscriptionType :: Out.ObjectType (Either SomeException)
|
||||
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ EventStreamResolver quoteField (pure $ Type.Object mempty)
|
||||
$ pure $ yield $ Type.Object mempty
|
||||
$ EventStreamResolver quoteField (pure $ Object mempty)
|
||||
$ pure $ yield $ Object mempty
|
||||
where
|
||||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
||||
|
@ -70,6 +172,13 @@ quoteType = Out.ObjectType "Quote" Nothing []
|
|||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
schoolType :: EnumType
|
||||
schoolType = EnumType "School" Nothing $ HashMap.fromList
|
||||
[ ("NOMINALISM", EnumValue Nothing)
|
||||
, ("REALISM", EnumValue Nothing)
|
||||
, ("IDEALISM", EnumValue Nothing)
|
||||
]
|
||||
|
||||
type EitherStreamOrValue = Either
|
||||
(ResponseEventStream (Either SomeException) Aeson.Value)
|
||||
(Response Aeson.Value)
|
||||
|
@ -118,6 +227,99 @@ spec =
|
|||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "errors on invalid output enum values" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.object
|
||||
[ "school" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Enum value completion failed."
|
||||
, locations = [Location 1 17]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { school } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "gives location information for non-null unions" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.object
|
||||
[ "interest" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Union value completion failed."
|
||||
, locations = [Location 1 17]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { interest } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "gives location information for invalid interfaces" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.object
|
||||
[ "majorWork" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Interface value completion failed."
|
||||
, locations = [Location 1 17]
|
||||
, path = []
|
||||
}
|
||||
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'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.Null
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Argument coercing failed."
|
||||
, locations = [Location 1 15]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: true) { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Aeson.object
|
||||
[ "philosopher" .= Aeson.object
|
||||
[ "century" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Result coercion failed."
|
||||
, locations = [Location 1 26]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { century } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Aeson.object
|
||||
[ "genres" .= Aeson.Null
|
||||
]
|
||||
executionErrors = pure $ Error
|
||||
{ message = "PhilosopherException"
|
||||
, locations = [Location 1 3]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ genres }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
context "Subscription" $
|
||||
it "subscribes" $
|
||||
let data'' = Aeson.object
|
||||
|
|
|
@ -49,16 +49,18 @@ catType :: ObjectType IO
|
|||
catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("nickname", nicknameResolver)
|
||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
||||
, ("doesKnowCommands", doesKnowCommandsResolver)
|
||||
, ("meowVolume", meowVolumeResolver)
|
||||
]
|
||||
where
|
||||
meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
|
||||
meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3
|
||||
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "catCommand"
|
||||
$ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
|
||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
||||
doesKnowCommandsType = In.NonNullListType
|
||||
$ In.NonNullEnumType catCommandType
|
||||
doesKnowCommandsField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "catCommands"
|
||||
$ In.Argument Nothing doesKnowCommandsType Nothing
|
||||
doesKnowCommandsResolver = ValueResolver doesKnowCommandsField
|
||||
$ pure $ Boolean True
|
||||
|
||||
nameResolver :: Resolver IO
|
||||
|
@ -845,7 +847,7 @@ spec =
|
|||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "providedRequiredArgumentsRule" $
|
||||
context "providedRequiredArgumentsRule" $ do
|
||||
it "checks for (non-)nullable arguments" $
|
||||
let queryString = [r|
|
||||
{
|
||||
|
@ -866,17 +868,17 @@ spec =
|
|||
context "variablesInAllowedPositionRule" $ do
|
||||
it "rejects wrongly typed variable arguments" $
|
||||
let queryString = [r|
|
||||
query catCommandArgQuery($catCommandArg: CatCommand) {
|
||||
cat {
|
||||
doesKnowCommand(catCommand: $catCommandArg)
|
||||
query dogCommandArgQuery($dogCommandArg: DogCommand) {
|
||||
dog {
|
||||
doesKnowCommand(dogCommand: $dogCommandArg)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Variable \"$catCommandArg\" of type \
|
||||
\\"CatCommand\" used in position expecting type \
|
||||
\\"!CatCommand\"."
|
||||
"Variable \"$dogCommandArg\" of type \
|
||||
\\"DogCommand\" used in position expecting type \
|
||||
\\"!DogCommand\"."
|
||||
, locations = [AST.Location 2 44]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
@ -897,7 +899,7 @@ spec =
|
|||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
context "valuesOfCorrectTypeRule" $
|
||||
context "valuesOfCorrectTypeRule" $ do
|
||||
it "rejects values of incorrect types" $
|
||||
let queryString = [r|
|
||||
{
|
||||
|
@ -912,3 +914,49 @@ spec =
|
|||
, locations = [AST.Location 4 52]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "uses the location of a single list value" $
|
||||
let queryString = [r|
|
||||
{
|
||||
cat {
|
||||
doesKnowCommands(catCommands: [3])
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Value 3 cannot be coerced to type \"!CatCommand\"."
|
||||
, locations = [AST.Location 4 54]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "validates input object properties once" $
|
||||
let queryString = [r|
|
||||
{
|
||||
findDog(complex: { name: 3 }) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Value 3 cannot be coerced to type \"!String\"."
|
||||
, locations = [AST.Location 3 46]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "checks for required list members" $
|
||||
let queryString = [r|
|
||||
{
|
||||
cat {
|
||||
doesKnowCommands(catCommands: [null])
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"List of non-null values of type \"CatCommand\" \
|
||||
\cannot contain null values."
|
||||
, locations = [AST.Location 4 54]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
|
Loading…
Reference in New Issue