diff options
| -rw-r--r-- | CHANGELOG.md | 18 | ||||
| -rw-r--r-- | graphql.cabal | 9 | ||||
| -rw-r--r-- | src/Language/GraphQL.hs | 24 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 11 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs | 7 | ||||
| -rw-r--r-- | src/Language/GraphQL/Error.hs | 40 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 5 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 6 | ||||
| -rw-r--r-- | src/Test/Hspec/GraphQL.hs | 4 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/EncoderSpec.hs | 5 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 209 | ||||
| -rw-r--r-- | tests/Schemas/HeroSchema.hs | 8 |
12 files changed, 197 insertions, 149 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 69663e9..0ce7624 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/graphql.cabal b/graphql.cabal index c50029e..c448f0e 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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, diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index b64cf42..4f3e8d9 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -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'. diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 0d448df..54967ea 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index ecefaf6..ab1f36f 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -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 diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 4e461f0..87ee702 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 9bc6b10..4725d74 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -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(..) diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index d7cc395..8c3156b 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -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 diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs index 5d812bf..a848c15 100644 --- a/src/Test/Hspec/GraphQL.hs +++ b/src/Test/Hspec/GraphQL.hs @@ -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 diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index bc6aac4..febd6fd 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -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" diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 73d62b4..c313df0 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -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 - - 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 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 variable coercion error" $ + let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }" + twoQueries = namedQuery "A" <> " " <> namedQuery "B" + + it "throws operation name is required error" $ do + let expectedErrorMessage = "Operation name is required" + actual <- parseAndExecute philosopherSchema Nothing mempty twoQueries + actual `shouldContainError` expectedErrorMessage + + it "throws operation not found error" $ do + let expectedErrorMessage = "Operation \"C\" is not found" + actual <- parseAndExecute philosopherSchema (Just "C") mempty twoQueries + actual `shouldContainError` expectedErrorMessage + + it "throws variable coercion error" $ do let data'' = Null executionErrors = pure $ Error { message = "Failed to coerce the variable $id: String." @@ -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 diff --git a/tests/Schemas/HeroSchema.hs b/tests/Schemas/HeroSchema.hs index 71b7a10..63c461c 100644 --- a/tests/Schemas/HeroSchema.hs +++ b/tests/Schemas/HeroSchema.hs @@ -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 |