diff options
| -rw-r--r-- | CHANGELOG.md | 12 | ||||
| -rw-r--r-- | graphql.cabal | 13 | ||||
| -rw-r--r-- | src/Language/GraphQL.hs | 45 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Document.hs | 8 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 51 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/Arbitrary.hs | 99 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/ParserSpec.hs | 105 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 76 | ||||
| -rw-r--r-- | tests/Schemas/HeroSchema.hs | 70 |
10 files changed, 411 insertions, 72 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index bfd8aa2..69663e9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,17 @@ The format is based on and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.0.3.0] - 2022-03-27 +### Fixed +- Index position in error path. (Index and Segment paths of a field have been + swapped). +- Parsing empty list as an argument. + +### Added +- quickCheck Parser test for arguments. Arbitrary instances for Language.GraphQL.AST.Document. +- Enhanced query error messages. Add tests for these cases. +- Allow version 2.0 of the text package. + ## [1.0.2.0] - 2021-12-26 ### Added - `Serialize` instance for `Type.Definition.Value`. @@ -466,6 +477,7 @@ and this project adheres to ### Added - Data types for the GraphQL language. +[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.3.0&rev_to=v1.0.2.0 [1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.2.0&rev_to=v1.0.1.0 [1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0 [1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0 diff --git a/graphql.cabal b/graphql.cabal index daf020f..c50029e 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: graphql -version: 1.0.2.0 +version: 1.0.3.0 synopsis: Haskell GraphQL implementation description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. category: Language @@ -22,8 +22,7 @@ extra-source-files: README.md tested-with: GHC == 8.10.7, - GHC == 9.0.1, - GHC == 9.2.1 + GHC == 9.2.2 source-repository head type: git @@ -72,7 +71,7 @@ library megaparsec >= 9.0 && < 10, parser-combinators >= 1.3 && < 2, template-haskell >= 2.16 && < 3, - text ^>= 1.2.4, + text >= 1.2 && < 3, transformers ^>= 0.5.6, unordered-containers ^>= 0.2.14, vector ^>= 0.12.3 @@ -93,12 +92,14 @@ test-suite graphql-test Language.GraphQL.AST.EncoderSpec Language.GraphQL.AST.LexerSpec Language.GraphQL.AST.ParserSpec + Language.GraphQL.AST.Arbitrary Language.GraphQL.ErrorSpec Language.GraphQL.Execute.CoerceSpec Language.GraphQL.Execute.OrderedMapSpec Language.GraphQL.ExecuteSpec Language.GraphQL.Type.OutSpec Language.GraphQL.Validate.RulesSpec + Schemas.HeroSchema hs-source-dirs: tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall @@ -113,5 +114,7 @@ test-suite graphql-test hspec-megaparsec ^>= 2.2.0, megaparsec, text, - unordered-containers + unordered-containers, + containers, + vector default-language: Haskell2010 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 20bb123..b64cf42 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -1,9 +1,8 @@ {-# LANGUAGE CPP #-} - -#ifdef WITH_JSON {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +#ifdef WITH_JSON -- | This module provides the functions to parse and execute @GraphQL@ queries. module Language.GraphQL ( graphql @@ -79,6 +78,46 @@ graphqlSubs schema operationName variableValues document' = #else -- | This module provides the functions to parse and execute @GraphQL@ queries. module Language.GraphQL - ( + ( graphql ) where + +import Control.Monad.Catch (MonadCatch) +import Data.HashMap.Strict (HashMap) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Language.GraphQL.AST as Full +import Language.GraphQL.Error +import Language.GraphQL.Execute +import qualified Language.GraphQL.Validate as Validate +import Language.GraphQL.Type.Schema (Schema) +import Prelude hiding (null) +import Text.Megaparsec (parse) + +-- | If the text parses correctly as a @GraphQL@ query the query is +-- executed using the given 'Schema'. +-- +-- An operation name can be given if the document contains multiple operations. +graphql :: (MonadCatch m, VariableValue a, Serialize b) + => Schema m -- ^ Resolvers. + -> Maybe Text -- ^ Operation name. + -> HashMap Full.Name a -- ^ Variable substitution function. + -> Text -- ^ Text representing a @GraphQL@ request document. + -> m (Either (ResponseEventStream m b) (Response b)) -- ^ Response. +graphql schema operationName variableValues document' = + case parse Full.document "" document' of + Left errorBundle -> pure <$> parseError errorBundle + Right parsed -> + case validate parsed of + Seq.Empty -> execute schema operationName variableValues parsed + errors -> pure $ pure + $ Response null + $ fromValidationError <$> errors + where + validate = Validate.document schema Validate.specifiedRules + fromValidationError Validate.Error{..} = Error + { message = Text.pack message + , locations = locations + , path = [] + } #endif diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index a698d2e..ea640df 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -49,6 +49,8 @@ module Language.GraphQL.AST.Document , Value(..) , VariableDefinition(..) , escape + , showVariableName + , showVariable ) where import Data.Char (ord) @@ -339,6 +341,12 @@ data VariableDefinition = VariableDefinition Name Type (Maybe (Node ConstValue)) Location deriving (Eq, Show) +showVariableName :: VariableDefinition -> String +showVariableName (VariableDefinition name _ _ _) = "$" <> Text.unpack name + +showVariable :: VariableDefinition -> String +showVariable var@(VariableDefinition _ type' _ _) = showVariableName var <> ":" <> " " <> show type' + -- ** Type References -- | Type representation. diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 19251ab..e19823c 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -450,8 +450,8 @@ value = Full.Variable <$> variable <|> Full.Null <$ nullValue <|> Full.String <$> stringValue <|> Full.Enum <$> try enumValue - <|> Full.List <$> brackets (some $ valueNode value) - <|> Full.Object <$> braces (some $ objectField $ valueNode value) + <|> Full.List <$> brackets (many $ valueNode value) + <|> Full.Object <$> braces (many $ objectField $ valueNode value) <?> "Value" constValue :: Parser Full.ConstValue diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 476cc50..5ceb616 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -61,6 +61,7 @@ import Language.GraphQL.Error , ResponseEventStream ) import Prelude hiding (null) +import Language.GraphQL.AST.Document (showVariableName) newtype ExecutorT m a = ExecutorT { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a @@ -190,32 +191,42 @@ data QueryError tell :: Monad m => Seq Error -> ExecutorT m () tell = ExecutorT . lift . Writer.tell +operationNameErrorText :: Text +operationNameErrorText = Text.unlines + [ "Named operations must be provided with the name of the desired operation." + , "See https://spec.graphql.org/June2018/#sec-Language.Document description." + ] + queryError :: QueryError -> Error queryError OperationNameRequired = - Error{ message = "Operation name is required.", locations = [], path = [] } + let queryErrorMessage = "Operation name is required. " <> operationNameErrorText + in Error{ message = queryErrorMessage, locations = [], path = [] } queryError (OperationNotFound operationName) = - let queryErrorMessage = Text.concat - [ "Operation \"" - , Text.pack operationName - , "\" not found." + let queryErrorMessage = Text.unlines + [ Text.concat + [ "Operation \"" + , Text.pack operationName + , "\" is not found in the named operations you've provided. " + ] + , operationNameErrorText ] in Error{ message = queryErrorMessage, locations = [], path = [] } queryError (CoercionError variableDefinition) = - let Full.VariableDefinition variableName _ _ location = variableDefinition + let (Full.VariableDefinition _ _ _ location) = variableDefinition queryErrorMessage = Text.concat - [ "Failed to coerce the variable \"" - , variableName - , "\"." + [ "Failed to coerce the variable " + , Text.pack $ Full.showVariable variableDefinition + , "." ] in Error{ message = queryErrorMessage, locations = [location], path = [] } queryError (UnknownInputType variableDefinition) = - let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition + let Full.VariableDefinition _ variableTypeName _ location = variableDefinition queryErrorMessage = Text.concat - [ "Variable \"" - , variableName - , "\" has unknown type \"" + [ "Variable " + , Text.pack $ showVariableName variableDefinition + , " has unknown type " , Text.pack $ show variableTypeName - , "\"." + , "." ] in Error{ message = queryErrorMessage, locations = [location], path = [] } @@ -375,6 +386,7 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath = , Handler (resolverHandler fieldLocation) ] where + fieldErrorPath = fieldsSegment fields : errorPath inputCoercionHandler :: (MonadCatch m, Serialize a) => Full.Location -> InputCoercionException @@ -402,17 +414,16 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath = then throwM e else returnError newError exceptionHandler errorLocation e = - let newPath = fieldsSegment fields : errorPath - newError = constructError e errorLocation newPath + let newError = constructError e errorLocation fieldErrorPath in if Out.isNonNullType fieldType - then throwM $ FieldException errorLocation newPath e + then throwM $ FieldException errorLocation fieldErrorPath e else returnError newError returnError newError = tell (Seq.singleton newError) >> pure null go fieldName inputArguments = do argumentValues <- coerceArgumentValues argumentTypes inputArguments resolvedValue <- resolveFieldValue resolveFunction objectValue fieldName argumentValues - completeValue fieldType fields errorPath resolvedValue + completeValue fieldType fields fieldErrorPath resolvedValue (resolverField, resolveFunction) = resolverPair Out.Field _ fieldType argumentTypes = resolverField @@ -445,6 +456,7 @@ resolveAbstractType abstractType values' _ -> pure Nothing | otherwise = pure Nothing +-- https://spec.graphql.org/October2021/#sec-Value-Completion completeValue :: (MonadCatch m, Serialize a) => Out.Type m -> NonEmpty (Transform.Field m) @@ -476,8 +488,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) = $ ValueCompletionException (show outputType) $ Type.Enum enum completeValue (Out.ObjectBaseType objectType) fields errorPath result - = executeSelectionSet (mergeSelectionSets fields) objectType result - $ fieldsSegment fields : errorPath + = executeSelectionSet (mergeSelectionSets fields) objectType result errorPath completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result | Type.Object objectMap <- result = do let abstractType = Type.Internal.AbstractInterfaceType interfaceType diff --git a/tests/Language/GraphQL/AST/Arbitrary.hs b/tests/Language/GraphQL/AST/Arbitrary.hs new file mode 100644 index 0000000..8d0544e --- /dev/null +++ b/tests/Language/GraphQL/AST/Arbitrary.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.GraphQL.AST.Arbitrary where + +import qualified Language.GraphQL.AST.Document as Doc +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) +import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..)) +import Test.QuickCheck.Gen (Gen (..)) +import Data.Text (Text, pack) + +newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show) + +alpha :: String +alpha = ['a'..'z'] <> ['A'..'Z'] + +num :: String +num = ['0'..'9'] + +instance Arbitrary AnyPrintableChar where + arbitrary = AnyPrintableChar <$> elements chars + where + chars = alpha <> num <> ['_'] + +newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show) + +instance Arbitrary AnyPrintableText where + arbitrary = do + nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar)) + pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr) + +-- https://spec.graphql.org/June2018/#Name +newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show) + +instance Arbitrary AnyName where + arbitrary = do + firstChar <- elements $ alpha <> ['_'] + rest <- (arbitrary :: Gen [AnyPrintableChar]) + pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest) + +newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show) + +instance Arbitrary AnyLocation where + arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary) + +newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (AnyNode a) where + arbitrary = do + (AnyLocation location') <- arbitrary + node' <- flip Doc.Node location' <$> arbitrary + pure $ AnyNode node' + +newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (AnyObjectField a) where + arbitrary = do + name' <- getAnyName <$> arbitrary + value' <- getAnyNode <$> arbitrary + location' <- getAnyLocation <$> arbitrary + pure $ AnyObjectField $ Doc.ObjectField name' value' location' + +newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show) + +instance Arbitrary AnyValue where + arbitrary = AnyValue <$> oneof + [ variableGen + , Doc.Int <$> arbitrary + , Doc.Float <$> arbitrary + , Doc.String <$> (getAnyPrintableText <$> arbitrary) + , Doc.Boolean <$> arbitrary + , MkGen $ \_ _ -> Doc.Null + , Doc.Enum <$> (getAnyName <$> arbitrary) + , Doc.List <$> listGen + , Doc.Object <$> objectGen + ] + where + variableGen :: Gen Doc.Value + variableGen = Doc.Variable <$> (getAnyName <$> arbitrary) + listGen :: Gen [Doc.Node Doc.Value] + listGen = (resize 5 . listOf) nodeGen + nodeGen = do + node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue)) + pure (getAnyValue <$> node') + objectGen :: Gen [Doc.ObjectField Doc.Value] + objectGen = resize 1 $ do + list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue))) + pure $ map (fmap getAnyValue . getAnyObjectField) list + +newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (AnyArgument a) where + arbitrary = do + name' <- getAnyName <$> arbitrary + (AnyValue value') <- arbitrary + (AnyLocation location') <- arbitrary + pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location' + +printArgument :: AnyArgument AnyValue -> Text +printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value' diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 702beab..13faa21 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -5,46 +5,78 @@ module Language.GraphQL.AST.ParserSpec ) where import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) +import qualified Data.Text as Text import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc import Language.GraphQL.AST.Parser import Language.GraphQL.TH -import Test.Hspec (Spec, describe, it) +import Test.Hspec (Spec, describe, it, context) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (parse) +import Test.QuickCheck (property, NonEmptyList (..), mapSize) +import Language.GraphQL.AST.Arbitrary spec :: Spec spec = describe "Parser" $ do it "accepts BOM header" $ parse document "" `shouldSucceedOn` "\xfeff{foo}" - it "accepts block strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: """Argument""") - }|] - - it "accepts strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: "Argument") - }|] - - it "accepts two required arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth($username: String!, $password: String!){ - test - }|] - - it "accepts two string arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth{ - test(username: "username", password: "password") - }|] - - it "accepts two block string arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth{ - test(username: """username""", password: """password""") - }|] + context "Arguments" $ do + it "accepts block strings as argument" $ + parse document "" `shouldSucceedOn` [gql|{ + hello(text: """Argument""") + }|] + + it "accepts strings as argument" $ + parse document "" `shouldSucceedOn` [gql|{ + hello(text: "Argument") + }|] + + it "accepts int as argument1" $ + parse document "" `shouldSucceedOn` [gql|{ + user(id: 4) + }|] + + it "accepts boolean as argument" $ + parse document "" `shouldSucceedOn` [gql|{ + hello(flag: true) { field1 } + }|] + + it "accepts float as argument" $ + parse document "" `shouldSucceedOn` [gql|{ + body(height: 172.5) { height } + }|] + + it "accepts empty list as argument" $ + parse document "" `shouldSucceedOn` [gql|{ + query(list: []) { field1 } + }|] + + it "accepts two required arguments" $ + parse document "" `shouldSucceedOn` [gql| + mutation auth($username: String!, $password: String!){ + test + }|] + + it "accepts two string arguments" $ + parse document "" `shouldSucceedOn` [gql| + mutation auth{ + test(username: "username", password: "password") + }|] + + it "accepts two block string arguments" $ + parse document "" `shouldSucceedOn` [gql| + mutation auth{ + test(username: """username""", password: """password""") + }|] + + it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> + let + query' :: Text + arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) + query' = "query(" <> Text.intercalate ", " arguments <> ")" in + parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") it "parses minimal schema definition" $ parse document "" `shouldSucceedOn` [gql|schema { query: Query }|] @@ -95,16 +127,6 @@ spec = describe "Parser" $ do } |] - it "parses minimal enum type definition" $ - parse document "" `shouldSucceedOn` [gql| - enum Direction { - NORTH - EAST - SOUTH - WEST - } - |] - it "parses minimal input object type definition" $ parse document "" `shouldSucceedOn` [gql| input Point2D { @@ -202,6 +224,13 @@ spec = describe "Parser" $ do } |] + it "rejects empty selection set" $ + parse document "" `shouldFailOn` [gql| + query { + innerField {} + } + |] + it "parses documents beginning with a comment" $ parse document "" `shouldSucceedOn` [gql| """ diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 5eafb2e..73d62b4 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} + module Language.GraphQL.ExecuteSpec ( spec ) where @@ -20,12 +21,17 @@ import Language.GraphQL.Error import Language.GraphQL.Execute (execute) import Language.GraphQL.TH import qualified Language.GraphQL.Type.Schema as Schema +import qualified Language.GraphQL.Type as Type import Language.GraphQL.Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Prelude hiding (id) import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) +import Schemas.HeroSchema (heroSchema) +import Data.Maybe (fromJust) +import qualified Data.Sequence as Seq +import qualified Data.Text as Text data PhilosopherException = PhilosopherException deriving Show @@ -178,7 +184,7 @@ quoteType = Out.ObjectType "Quote" Nothing [] quoteField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty -schoolType :: EnumType +schoolType :: Type.EnumType schoolType = EnumType "School" Nothing $ HashMap.fromList [ ("NOMINALISM", EnumValue Nothing) , ("REALISM", EnumValue Nothing) @@ -186,12 +192,12 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList ] type EitherStreamOrValue = Either - (ResponseEventStream (Either SomeException) Value) - (Response Value) + (ResponseEventStream (Either SomeException) Type.Value) + (Response Type.Value) execute' :: Document -> Either SomeException EitherStreamOrValue execute' = - execute philosopherSchema Nothing (mempty :: HashMap Name Value) + execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) spec :: Spec spec = @@ -335,6 +341,68 @@ spec = $ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }" in actual `shouldBe` 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 data'' = Null + executionErrors = pure $ Error + { message = "Failed to coerce the variable $id: String." + , locations =[Location 1 7] + , 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 + + it "throws variable unkown input type error" $ + let data'' = Null + executionErrors = pure $ Error + { message = "Variable $id has unknown type Cat." + , locations =[Location 1 7] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }" + in actual `shouldBe` expected + + context "Error path" $ do + let executeHero :: Document -> Either SomeException 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 + Error _ _ path' = fromJust $ Seq.lookup 0 errors' + expected = [Segment "hero", Segment "friends", Index 0, Segment "name"] + in path' `shouldBe` expected + context "Subscription" $ it "subscribes" $ let data'' = Object diff --git a/tests/Schemas/HeroSchema.hs b/tests/Schemas/HeroSchema.hs new file mode 100644 index 0000000..71b7a10 --- /dev/null +++ b/tests/Schemas/HeroSchema.hs @@ -0,0 +1,70 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +{-# LANGUAGE OverloadedStrings #-} + +module Schemas.HeroSchema (heroSchema) where + +import Control.Exception (Exception(..), SomeException) +import Control.Monad.Catch (throwM) +import Language.GraphQL.Error (ResolverException (..)) +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type as Type +import Language.GraphQL.Type.Schema (schemaWithTypes) +import qualified Data.HashMap.Strict as HashMap +import Data.Typeable (cast) +import qualified Language.GraphQL.Type.Out as Out + +data HeroException = HeroException + deriving Show + +instance Exception HeroException where + toException = toException. ResolverException + fromException e = do + ResolverException resolverException <- fromException e + cast resolverException + +heroSchema :: Type.Schema (Either SomeException) +heroSchema = + schemaWithTypes Nothing queryType Nothing Nothing [] mempty + +type ObjectType = Out.ObjectType (Either SomeException) + +queryType :: ObjectType +queryType = Out.ObjectType "Query" Nothing [] + $ HashMap.fromList + [ ("hero", Out.ValueResolver heroField heroResolver) + ] + where + heroField = Out.Field Nothing (Out.NamedObjectType heroType) + $ HashMap.singleton "id" + $ In.Argument Nothing (In.NamedScalarType Type.id) Nothing + heroResolver = pure $ Type.Object mempty + +stringField :: Out.Field (Either SomeException) +stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty + +heroType :: ObjectType +heroType = Out.ObjectType "Hero" Nothing [] $ HashMap.fromList resolvers + where + resolvers = + [ ("id", Out.ValueResolver stringField (pure $ Type.String "4111")) + , ("name", Out.ValueResolver stringField (pure $ Type.String "R2D2")) + , ("friends", Out.ValueResolver friendsField (pure $ Type.List [luke])) + ] + friendsField = Out.Field Nothing (Out.ListType $ Out.NonNullObjectType lukeType) HashMap.empty + -- This list values are ignored because of current realisation (types and resolvers are the same entity) + -- The values from lukeType will be used + luke = Type.Object $ HashMap.fromList + [ ("id", "dfdfdf") + , ("name", "dfdfdff") + ] + +lukeType :: ObjectType +lukeType = Out.ObjectType "Luke" Nothing [] $ HashMap.fromList resolvers + where + resolvers = + [ ("id", Out.ValueResolver stringField (pure $ Type.String "1000")) + , ("name", Out.ValueResolver stringField (throwM HeroException)) + ] |