Compare commits
7 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | a5cf0a32e8 | |
Eugen Wissner | 2f9881bb21 | |
Eugen Wissner | bf2e4925b4 | |
Eugen Wissner | 2321d1a1bc | |
Eugen Wissner | 2f19093803 | |
Eugen Wissner | 0dac9701bc | |
Eugen Wissner | 0d25f482dd |
18
CHANGELOG.md
18
CHANGELOG.md
|
@ -6,6 +6,19 @@ The format is based on
|
|||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [1.1.0.0] - 2022-12-24
|
||||
### Changed
|
||||
- Removed deprecated `Language.GraphQL.Error` functions: `addErr`, `addErrMsg`,
|
||||
`singleError`.
|
||||
- Deprecate `Resolution`, `CollectErrsT` and `runCollectErrs` in the `Error`
|
||||
module. It was already noted in the documentation that these symbols are
|
||||
deprecated, now a pragma is added.
|
||||
- `Language.GraphQL`: Added information about the *json* flag and switching to
|
||||
*graphql-spice* for JSON support.
|
||||
|
||||
### Added
|
||||
- Partial schema printing: operation type encoder.
|
||||
|
||||
## [1.0.3.0] - 2022-03-27
|
||||
### Fixed
|
||||
- Index position in error path. (Index and Segment paths of a field have been
|
||||
|
@ -477,8 +490,9 @@ and this project adheres to
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.3.0&rev_to=v1.0.2.0
|
||||
[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.2.0&rev_to=v1.0.1.0
|
||||
[1.1.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.1.0.0&rev_to=v1.0.3.0
|
||||
[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.3.0&rev_to=v1.0.2.0
|
||||
[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.2.0&rev_to=v1.0.1.0
|
||||
[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0
|
||||
[1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0
|
||||
[0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
cabal-version: 2.4
|
||||
|
||||
name: graphql
|
||||
version: 1.0.3.0
|
||||
version: 1.1.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
|
@ -11,7 +11,7 @@ author: Danny Navarro <j@dannynavarro.net>,
|
|||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019-2021 Eugen Wissner,
|
||||
copyright: (c) 2019-2022 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: MPL-2.0 AND BSD-3-Clause
|
||||
license-files: LICENSE,
|
||||
|
@ -22,7 +22,7 @@ extra-source-files:
|
|||
README.md
|
||||
tested-with:
|
||||
GHC == 8.10.7,
|
||||
GHC == 9.2.2
|
||||
GHC == 9.2.4
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
@ -30,7 +30,7 @@ source-repository head
|
|||
|
||||
flag Json
|
||||
description: Whether to build against @aeson 1.x@
|
||||
default: True
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
library
|
||||
|
@ -111,6 +111,7 @@ test-suite graphql-test
|
|||
exceptions,
|
||||
graphql,
|
||||
hspec ^>= 2.9.1,
|
||||
hspec-expectations ^>= 0.8.2,
|
||||
hspec-megaparsec ^>= 2.2.0,
|
||||
megaparsec,
|
||||
text,
|
||||
|
|
|
@ -4,6 +4,28 @@
|
|||
|
||||
#ifdef WITH_JSON
|
||||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
--
|
||||
-- The content of this module depends on the value of the __json__ flag, which
|
||||
-- is currently on by default. This behavior will change in the future, the flag
|
||||
-- will be switched off by default and then removed.
|
||||
--
|
||||
-- This documentation is generated with the enabled __json__ flag and functions
|
||||
-- described here support JSON and are deprecated. JSON instances are provided
|
||||
-- now by an additional package, __graphql-spice__. To start using the new
|
||||
-- package create __cabal.project__ in the root directory of your project with
|
||||
-- the following contents:
|
||||
--
|
||||
-- @
|
||||
-- packages: .
|
||||
-- constraints: graphql -json
|
||||
-- @
|
||||
--
|
||||
-- Then add __graphql-spice__ as dependency.
|
||||
--
|
||||
-- The new version of this module defines only one function, @graphql@, which
|
||||
-- works with the internal GraphQL value representation used by this lbirary.
|
||||
-- Refer to @Language.GraphQL.JSON.graphql@ in __graphql-spice__ for the
|
||||
-- function that accepts and returns JSON.
|
||||
module Language.GraphQL
|
||||
( graphql
|
||||
, graphqlSubs
|
||||
|
@ -23,6 +45,7 @@ import qualified Language.GraphQL.Validate as Validate
|
|||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
{-# DEPRECATED graphql "Use graphql-spice package instead" #-}
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema'.
|
||||
graphql :: MonadCatch m
|
||||
|
@ -31,6 +54,7 @@ graphql :: MonadCatch m
|
|||
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
|
||||
graphql schema = graphqlSubs schema mempty mempty
|
||||
|
||||
{-# DEPRECATED graphqlSubs "Use graphql-spice package instead" #-}
|
||||
-- | If the text parses correctly as a @GraphQL@ query the substitution is
|
||||
-- applied to the query and the query is then executed using to the given
|
||||
-- 'Schema'.
|
||||
|
|
|
@ -11,6 +11,7 @@ module Language.GraphQL.AST.Encoder
|
|||
, directive
|
||||
, document
|
||||
, minified
|
||||
, operationType
|
||||
, pretty
|
||||
, type'
|
||||
, value
|
||||
|
@ -34,7 +35,7 @@ import qualified Language.GraphQL.AST.Document as Full
|
|||
-- Use 'pretty' or 'minified' to construct the formatter.
|
||||
data Formatter
|
||||
= Minified
|
||||
| Pretty Word
|
||||
| Pretty !Word
|
||||
|
||||
-- | Constructs a formatter for pretty printing.
|
||||
pretty :: Formatter
|
||||
|
@ -101,7 +102,7 @@ variableDefinition formatter variableDefinition' =
|
|||
in variable variableName
|
||||
<> eitherFormat formatter ": " ":"
|
||||
<> type' variableType
|
||||
<> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue')
|
||||
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
|
||||
|
||||
defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text
|
||||
defaultValue formatter val
|
||||
|
@ -294,6 +295,12 @@ nonNullType :: Full.NonNullType -> Lazy.Text
|
|||
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
-- | Produces lowercase operation type: query, mutation or subscription.
|
||||
operationType :: Formatter -> Full.OperationType -> Lazy.Text
|
||||
operationType _formatter Full.Query = "query"
|
||||
operationType _formatter Full.Mutation = "mutation"
|
||||
operationType _formatter Full.Subscription = "subscription"
|
||||
|
||||
-- * Internal
|
||||
|
||||
between :: Char -> Char -> Lazy.Text -> Lazy.Text
|
||||
|
|
|
@ -58,6 +58,7 @@ import qualified Text.Megaparsec.Char.Lexer as Lexer
|
|||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Control.Monad (void)
|
||||
|
||||
-- | Standard parser.
|
||||
-- Accepts the type of the parsed token.
|
||||
|
@ -93,7 +94,7 @@ dollar = symbol "$"
|
|||
|
||||
-- | Parser for "@".
|
||||
at :: Parser ()
|
||||
at = symbol "@" >> pure ()
|
||||
at = void $ symbol "@"
|
||||
|
||||
-- | Parser for "&".
|
||||
amp :: Parser T.Text
|
||||
|
@ -101,7 +102,7 @@ amp = symbol "&"
|
|||
|
||||
-- | Parser for ":".
|
||||
colon :: Parser ()
|
||||
colon = symbol ":" >> pure ()
|
||||
colon = void $ symbol ":"
|
||||
|
||||
-- | Parser for "=".
|
||||
equals :: Parser T.Text
|
||||
|
@ -220,7 +221,7 @@ escapeSequence = do
|
|||
|
||||
-- | Parser for the "Byte Order Mark".
|
||||
unicodeBOM :: Parser ()
|
||||
unicodeBOM = optional (char '\xfeff') >> pure ()
|
||||
unicodeBOM = void $ optional $ char '\xfeff'
|
||||
|
||||
-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
|
||||
extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
|
||||
|
|
|
@ -15,16 +15,13 @@ module Language.GraphQL.Error
|
|||
, ResolverException(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, parseError
|
||||
, runCollectErrs
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||
import Control.Monad.Trans.State (StateT, runStateT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
|
@ -103,11 +100,9 @@ instance Exception ResolverException
|
|||
|
||||
-- * Deprecated
|
||||
|
||||
{-# DEPRECATED runCollectErrs "runCollectErrs was part of the old executor and isn't used anymore" #-}
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
--
|
||||
-- /runCollectErrs was part of the old executor and isn't used anymore, it will
|
||||
-- be deprecated in the future and removed./
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
=> HashMap Name (Schema.Type m)
|
||||
-> CollectErrsT m a
|
||||
|
@ -117,40 +112,13 @@ runCollectErrs types' res = do
|
|||
$ Resolution{ errors = Seq.empty, types = types' }
|
||||
pure $ Response dat errors
|
||||
|
||||
{-# DEPRECATED Resolution "Resolution was part of the old executor and isn't used anymore" #-}
|
||||
-- | Executor context.
|
||||
--
|
||||
-- /Resolution was part of the old executor and isn't used anymore, it will be
|
||||
-- deprecated in the future and removed./
|
||||
data Resolution m = Resolution
|
||||
{ errors :: Seq Error
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
}
|
||||
|
||||
{-# DEPRECATED CollectErrsT "CollectErrsT was part of the old executor and isn't used anymore" #-}
|
||||
-- | A wrapper to pass error messages around.
|
||||
--
|
||||
-- /CollectErrsT was part of the old executor and isn't used anymore, it will be
|
||||
-- deprecated in the future and removed./
|
||||
type CollectErrsT m = StateT (Resolution m) m
|
||||
|
||||
-- | Adds an error to the list of errors.
|
||||
{-# DEPRECATED #-}
|
||||
addErr :: Monad m => Error -> CollectErrsT m ()
|
||||
addErr v = modify appender
|
||||
where
|
||||
appender :: Monad m => Resolution m -> Resolution m
|
||||
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
|
||||
|
||||
{-# DEPRECATED #-}
|
||||
makeErrorMessage :: Text -> Error
|
||||
makeErrorMessage s = Error s [] []
|
||||
|
||||
-- | Constructs a response object containing only the error with the given
|
||||
-- message.
|
||||
{-# DEPRECATED #-}
|
||||
singleError :: Serialize a => Text -> Response a
|
||||
singleError message = Response null $ Seq.singleton $ Error message [] []
|
||||
|
||||
-- | Convenience function for just wrapping an error message.
|
||||
{-# DEPRECATED #-}
|
||||
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
||||
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
|
||||
|
|
|
@ -8,6 +8,11 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | Types and functions used for input and result coercion.
|
||||
--
|
||||
-- JSON instances in this module are only available with the __json__
|
||||
-- flag that is currently on by default, but will be disabled in the future.
|
||||
-- Refer to the documentation in the 'Language.GraphQL' module and to
|
||||
-- the __graphql-spice__ package.
|
||||
module Language.GraphQL.Execute.Coerce
|
||||
( Output(..)
|
||||
, Serialize(..)
|
||||
|
|
|
@ -54,7 +54,7 @@ import Data.HashMap.Strict (HashMap)
|
|||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (groupBy, sortBy, sortOn)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
|
@ -1551,9 +1551,9 @@ valuesOfCorrectTypeRule = ValueRule go constGo
|
|||
toConst Full.Null = Just Full.ConstNull
|
||||
toConst (Full.Enum enum) = Just $ Full.ConstEnum enum
|
||||
toConst (Full.List values) =
|
||||
Just $ Full.ConstList $ catMaybes $ toConstNode <$> values
|
||||
Just $ Full.ConstList $ mapMaybe toConstNode values
|
||||
toConst (Full.Object fields) = Just $ Full.ConstObject
|
||||
$ catMaybes $ constObjectField <$> fields
|
||||
$ mapMaybe constObjectField fields
|
||||
constObjectField Full.ObjectField{..}
|
||||
| Just constValue <- toConstNode value =
|
||||
Just $ Full.ObjectField name constValue location
|
||||
|
|
|
@ -9,7 +9,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Test helpers.
|
||||
module Test.Hspec.GraphQL
|
||||
module Test.Hspec.GraphQL {-# DEPRECATED "Use graphql-spice package instead" #-}
|
||||
( shouldResolve
|
||||
, shouldResolveTo
|
||||
) where
|
||||
|
@ -43,7 +43,7 @@ shouldResolve executor query = do
|
|||
_ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
#else
|
||||
module Test.Hspec.GraphQL
|
||||
module Test.Hspec.GraphQL {-# DEPRECATED "Use graphql-spice package instead" #-}
|
||||
(
|
||||
) where
|
||||
#endif
|
||||
|
|
|
@ -173,3 +173,8 @@ spec = do
|
|||
|] '\n'
|
||||
actual = definition pretty operation
|
||||
in actual `shouldBe` expected
|
||||
|
||||
describe "operationType" $
|
||||
it "produces lowercase mutation operation type" $
|
||||
let actual = operationType pretty Full.Mutation
|
||||
in actual `shouldBe` "mutation"
|
||||
|
|
|
@ -2,6 +2,10 @@
|
|||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
|
@ -9,7 +13,7 @@ module Language.GraphQL.ExecuteSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Data.Conduit
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
|
@ -27,11 +31,17 @@ import qualified Language.GraphQL.Type.In as In
|
|||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Prelude hiding (id)
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.Megaparsec (parse, errorBundlePretty)
|
||||
import Schemas.HeroSchema (heroSchema)
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Test.Hspec.Expectations
|
||||
( Expectation
|
||||
, expectationFailure
|
||||
)
|
||||
import Data.Either (fromRight)
|
||||
|
||||
data PhilosopherException = PhilosopherException
|
||||
deriving Show
|
||||
|
@ -42,7 +52,7 @@ instance Exception PhilosopherException where
|
|||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
philosopherSchema :: Schema (Either SomeException)
|
||||
philosopherSchema :: Schema IO
|
||||
philosopherSchema =
|
||||
schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
|
||||
where
|
||||
|
@ -52,7 +62,7 @@ philosopherSchema =
|
|||
, Schema.ObjectType bookCollectionType
|
||||
]
|
||||
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
queryType :: Out.ObjectType IO
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("philosopher", ValueResolver philosopherField philosopherResolver)
|
||||
|
@ -68,14 +78,14 @@ queryType = Out.ObjectType "Query" Nothing []
|
|||
genresField =
|
||||
let fieldType = Out.ListType $ Out.NonNullScalarType string
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
genresResolver :: Resolve (Either SomeException)
|
||||
genresResolver :: Resolve IO
|
||||
genresResolver = throwM PhilosopherException
|
||||
countField =
|
||||
let fieldType = Out.NonNullScalarType int
|
||||
in Out.Field Nothing fieldType HashMap.empty
|
||||
countResolver = pure ""
|
||||
|
||||
musicType :: Out.ObjectType (Either SomeException)
|
||||
musicType :: Out.ObjectType IO
|
||||
musicType = Out.ObjectType "Music" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
|
@ -85,7 +95,7 @@ musicType = Out.ObjectType "Music" Nothing []
|
|||
instrumentResolver = pure $ String "piano"
|
||||
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
poetryType :: Out.ObjectType (Either SomeException)
|
||||
poetryType :: Out.ObjectType IO
|
||||
poetryType = Out.ObjectType "Poetry" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
|
@ -95,10 +105,10 @@ poetryType = Out.ObjectType "Poetry" Nothing []
|
|||
genreResolver = pure $ String "Futurism"
|
||||
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
interestType :: Out.UnionType (Either SomeException)
|
||||
interestType :: Out.UnionType IO
|
||||
interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
|
||||
|
||||
philosopherType :: Out.ObjectType (Either SomeException)
|
||||
philosopherType :: Out.ObjectType IO
|
||||
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
|
@ -139,14 +149,14 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
|
|||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
firstLanguageResolver = pure Null
|
||||
|
||||
workType :: Out.InterfaceType (Either SomeException)
|
||||
workType :: Out.InterfaceType IO
|
||||
workType = Out.InterfaceType "Work" Nothing []
|
||||
$ HashMap.fromList fields
|
||||
where
|
||||
fields = [("title", titleField)]
|
||||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
bookType :: Out.ObjectType (Either SomeException)
|
||||
bookType :: Out.ObjectType IO
|
||||
bookType = Out.ObjectType "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
|
@ -156,7 +166,7 @@ bookType = Out.ObjectType "Book" Nothing [workType]
|
|||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen"
|
||||
|
||||
bookCollectionType :: Out.ObjectType (Either SomeException)
|
||||
bookCollectionType :: Out.ObjectType IO
|
||||
bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
|
@ -166,7 +176,7 @@ bookCollectionType = Out.ObjectType "Book" Nothing [workType]
|
|||
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
titleResolver = pure "The Three Critiques"
|
||||
|
||||
subscriptionType :: Out.ObjectType (Either SomeException)
|
||||
subscriptionType :: Out.ObjectType IO
|
||||
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ EventStreamResolver quoteField (pure $ Object mempty)
|
||||
|
@ -175,7 +185,7 @@ subscriptionType = Out.ObjectType "Subscription" Nothing []
|
|||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
||||
|
||||
quoteType :: Out.ObjectType (Either SomeException)
|
||||
quoteType :: Out.ObjectType IO
|
||||
quoteType = Out.ObjectType "Quote" Nothing []
|
||||
$ HashMap.singleton "quote"
|
||||
$ ValueResolver quoteField
|
||||
|
@ -192,12 +202,48 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
|
|||
]
|
||||
|
||||
type EitherStreamOrValue = Either
|
||||
(ResponseEventStream (Either SomeException) Type.Value)
|
||||
(ResponseEventStream IO Type.Value)
|
||||
(Response Type.Value)
|
||||
|
||||
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute' =
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
|
||||
-- Asserts that a query resolves to a value.
|
||||
shouldResolveTo :: Text.Text -> Response Type.Value -> Expectation
|
||||
shouldResolveTo querySource expected =
|
||||
case parse document "" querySource of
|
||||
(Right parsedDocument) ->
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) parsedDocument >>= go
|
||||
(Left errorBundle) -> expectationFailure $ errorBundlePretty errorBundle
|
||||
where
|
||||
go = \case
|
||||
Right result -> shouldBe result expected
|
||||
Left _ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
|
||||
-- Asserts that the executor produces an error that starts with a string.
|
||||
shouldContainError :: Either (ResponseEventStream IO Type.Value) (Response Type.Value)
|
||||
-> Text
|
||||
-> Expectation
|
||||
shouldContainError streamOrValue expected =
|
||||
case streamOrValue of
|
||||
Right response -> respond response
|
||||
Left _ -> expectationFailure
|
||||
"the query is expected to resolve to a value, but it resolved to an event stream"
|
||||
where
|
||||
startsWith :: Text.Text -> Text.Text -> Bool
|
||||
startsWith xs ys = Text.take (Text.length ys) xs == ys
|
||||
respond :: Response Type.Value -> Expectation
|
||||
respond Response{ errors }
|
||||
| any ((`startsWith` expected) . message) errors = pure ()
|
||||
| otherwise = expectationFailure
|
||||
"the query is expected to execute with errors, but the response doesn't contain any errors"
|
||||
|
||||
parseAndExecute :: Schema IO
|
||||
-> Maybe Text
|
||||
-> HashMap Name Type.Value
|
||||
-> Text
|
||||
-> IO (Either (ResponseEventStream IO Type.Value) (Response Type.Value))
|
||||
parseAndExecute schema' operation variables
|
||||
= either (pure . parseError) (execute schema' operation variables)
|
||||
. parse document ""
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
@ -213,9 +259,7 @@ spec =
|
|||
}
|
||||
|]
|
||||
expected = Response (Object mempty) mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" sourceQuery
|
||||
in actual `shouldBe` expected
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Query" $ do
|
||||
it "skips unknown fields" $
|
||||
|
@ -225,9 +269,8 @@ spec =
|
|||
$ HashMap.singleton "firstName"
|
||||
$ String "Friedrich"
|
||||
expected = Response data'' mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName surname } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { firstName surname } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
it "merges selections" $
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "philosopher"
|
||||
|
@ -237,9 +280,8 @@ spec =
|
|||
, ("lastName", String "Nietzsche")
|
||||
]
|
||||
expected = Response data'' mempty
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "errors on invalid output enum values" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
|
@ -250,9 +292,8 @@ spec =
|
|||
, path = [Segment "philosopher", Segment "school"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { school } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { school } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for non-null unions" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
|
@ -263,9 +304,8 @@ spec =
|
|||
, path = [Segment "philosopher", Segment "interest"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { interest } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { interest } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for invalid interfaces" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
|
@ -277,9 +317,8 @@ spec =
|
|||
, path = [Segment "philosopher", Segment "majorWork"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { majorWork { title } } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher { majorWork { title } } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for invalid scalar arguments" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
|
@ -290,9 +329,8 @@ spec =
|
|||
, path = [Segment "philosopher"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: true) { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: true) { lastName } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
|
@ -302,9 +340,8 @@ spec =
|
|||
, path = [Segment "philosopher", Segment "century"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { century } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: \"1\") { century } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "gives location information for failed result coercion" $
|
||||
let data'' = Object $ HashMap.singleton "genres" Null
|
||||
|
@ -314,9 +351,8 @@ spec =
|
|||
, path = [Segment "genres"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ genres }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ genres }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "sets data to null if a root field isn't nullable" $
|
||||
let executionErrors = pure $ Error
|
||||
|
@ -325,9 +361,8 @@ spec =
|
|||
, path = [Segment "count"]
|
||||
}
|
||||
expected = Response Null executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ count }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ count }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
it "detects nullability errors" $
|
||||
let data'' = Object $ HashMap.singleton "philosopher" Null
|
||||
|
@ -337,35 +372,24 @@ spec =
|
|||
, path = [Segment "philosopher", Segment "firstLanguage"]
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "queryError" $ do
|
||||
let
|
||||
namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
|
||||
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
|
||||
startsWith :: Text.Text -> Text.Text -> Bool
|
||||
startsWith xs ys = Text.take (Text.length ys) xs == ys
|
||||
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
|
||||
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
|
||||
|
||||
it "throws operation name is required error" $
|
||||
let expectedErrorMessage :: Text.Text
|
||||
expectedErrorMessage = "Operation name is required"
|
||||
Right (Right (Response _ executionErrors)) = either (pure . parseError) execute' $ parse document "" twoQueries
|
||||
Error msg _ _ = Seq.index executionErrors 0
|
||||
in msg `startsWith` expectedErrorMessage `shouldBe` True
|
||||
it "throws operation name is required error" $ do
|
||||
let expectedErrorMessage = "Operation name is required"
|
||||
actual <- parseAndExecute philosopherSchema Nothing mempty twoQueries
|
||||
actual `shouldContainError` expectedErrorMessage
|
||||
|
||||
it "throws operation not found error" $
|
||||
let expectedErrorMessage :: Text.Text
|
||||
expectedErrorMessage = "Operation \"C\" is not found"
|
||||
execute'' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute'' = execute philosopherSchema (Just "C") (mempty :: HashMap Name Type.Value)
|
||||
Right (Right (Response _ executionErrors)) = either (pure . parseError) execute''
|
||||
$ parse document "" twoQueries
|
||||
Error msg _ _ = Seq.index executionErrors 0
|
||||
in msg `startsWith` expectedErrorMessage `shouldBe` True
|
||||
it "throws operation not found error" $ do
|
||||
let expectedErrorMessage = "Operation \"C\" is not found"
|
||||
actual <- parseAndExecute philosopherSchema (Just "C") mempty twoQueries
|
||||
actual `shouldContainError` expectedErrorMessage
|
||||
|
||||
it "throws variable coercion error" $
|
||||
it "throws variable coercion error" $ do
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Failed to coerce the variable $id: String."
|
||||
|
@ -373,11 +397,10 @@ spec =
|
|||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
executeWithVars :: Document -> Either SomeException EitherStreamOrValue
|
||||
executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
|
||||
Right (Right actual) = either (pure . parseError) executeWithVars
|
||||
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
Right actual <- either (pure . parseError) executeWithVars
|
||||
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
actual `shouldBe` expected
|
||||
|
||||
it "throws variable unkown input type error" $
|
||||
let data'' = Null
|
||||
|
@ -387,31 +410,31 @@ spec =
|
|||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
sourceQuery = "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in sourceQuery `shouldResolveTo` expected
|
||||
|
||||
context "Error path" $ do
|
||||
let executeHero :: Document -> Either SomeException EitherStreamOrValue
|
||||
let executeHero :: Document -> IO EitherStreamOrValue
|
||||
executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Type.Value)
|
||||
|
||||
it "at the beggining of the list" $
|
||||
let Right (Right actual) = either (pure . parseError) executeHero
|
||||
$ parse document "" "{ hero(id: \"1\") { friends { name } } }"
|
||||
Response _ errors' = actual
|
||||
it "at the beggining of the list" $ do
|
||||
Right actual <- either (pure . parseError) executeHero
|
||||
$ parse document "" "{ hero(id: \"1\") { friends { name } } }"
|
||||
let Response _ errors' = actual
|
||||
Error _ _ path' = fromJust $ Seq.lookup 0 errors'
|
||||
expected = [Segment "hero", Segment "friends", Index 0, Segment "name"]
|
||||
in path' `shouldBe` expected
|
||||
in path' `shouldBe` expected
|
||||
|
||||
context "Subscription" $
|
||||
it "subscribes" $
|
||||
it "subscribes" $ do
|
||||
let data'' = Object
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ Object
|
||||
$ HashMap.singleton "quote"
|
||||
$ String "Naturam expelles furca, tamen usque recurret."
|
||||
expected = Response data'' mempty
|
||||
Right (Left stream) = either (pure . parseError) execute'
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Right (Just actual) = runConduit $ stream .| await
|
||||
in actual `shouldBe` expected
|
||||
Left stream <- execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
|
||||
$ fromRight (error "Parse error")
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Just actual <- runConduit $ stream .| await
|
||||
actual `shouldBe` expected
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
module Schemas.HeroSchema (heroSchema) where
|
||||
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Language.GraphQL.Error (ResolverException (..))
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
|
@ -25,11 +25,11 @@ instance Exception HeroException where
|
|||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
heroSchema :: Type.Schema (Either SomeException)
|
||||
heroSchema :: Type.Schema IO
|
||||
heroSchema =
|
||||
schemaWithTypes Nothing queryType Nothing Nothing [] mempty
|
||||
|
||||
type ObjectType = Out.ObjectType (Either SomeException)
|
||||
type ObjectType = Out.ObjectType IO
|
||||
|
||||
queryType :: ObjectType
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
|
@ -42,7 +42,7 @@ queryType = Out.ObjectType "Query" Nothing []
|
|||
$ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
|
||||
heroResolver = pure $ Type.Object mempty
|
||||
|
||||
stringField :: Out.Field (Either SomeException)
|
||||
stringField :: Out.Field IO
|
||||
stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
|
||||
|
||||
heroType :: ObjectType
|
||||
|
|
Loading…
Reference in New Issue