diff options
Diffstat (limited to 'tests/Language')
| -rw-r--r-- | tests/Language/GraphQL/AST/EncoderSpec.hs | 5 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 209 |
2 files changed, 121 insertions, 93 deletions
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 |