prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Eliminate non-exhaustive patterns in ExecuteSpec

Browse Source
This commit is contained in:
Eugen Wissner
2022-07-02 15:29:35 +02:00
parent 2f19093803
commit 2321d1a1bc
1 changed files with 67 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

118
tests/Language/GraphQL/ExecuteSpec.hs
View File

@@ -3,7 +3,9 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@@ -11,7 +13,7 @@ module Language.GraphQL.ExecuteSpec
( spec ( spec
) where ) where
import Control.Exception (Exception(..), SomeException, throwIO) import Control.Exception (Exception(..), SomeException)
import Control.Monad.Catch (throwM) import Control.Monad.Catch (throwM)
import Data.Conduit import Data.Conduit
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
@@ -33,6 +35,7 @@ import Text.Megaparsec (parse, errorBundlePretty)
import Schemas.HeroSchema (heroSchema) import Schemas.HeroSchema (heroSchema)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Test.Hspec.Expectations import Test.Hspec.Expectations
( Expectation ( Expectation
@@ -49,7 +52,7 @@ instance Exception PhilosopherException where
ResolverException resolverException <- fromException e ResolverException resolverException <- fromException e
cast resolverException cast resolverException
philosopherSchema :: Schema (Either SomeException) philosopherSchema :: Schema IO
philosopherSchema = philosopherSchema =
schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
where where
@@ -59,7 +62,7 @@ philosopherSchema =
, Schema.ObjectType bookCollectionType , Schema.ObjectType bookCollectionType
] ]
queryType :: Out.ObjectType (Either SomeException) queryType :: Out.ObjectType IO
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.fromList $ HashMap.fromList
[ ("philosopher", ValueResolver philosopherField philosopherResolver) [ ("philosopher", ValueResolver philosopherField philosopherResolver)
@@ -75,14 +78,14 @@ queryType = Out.ObjectType "Query" Nothing []
genresField = genresField =
let fieldType = Out.ListType $ Out.NonNullScalarType string let fieldType = Out.ListType $ Out.NonNullScalarType string
in Out.Field Nothing fieldType HashMap.empty in Out.Field Nothing fieldType HashMap.empty
genresResolver :: Resolve (Either SomeException) genresResolver :: Resolve IO
genresResolver = throwM PhilosopherException genresResolver = throwM PhilosopherException
countField = countField =
let fieldType = Out.NonNullScalarType int let fieldType = Out.NonNullScalarType int
in Out.Field Nothing fieldType HashMap.empty in Out.Field Nothing fieldType HashMap.empty
countResolver = pure "" countResolver = pure ""
musicType :: Out.ObjectType (Either SomeException) musicType :: Out.ObjectType IO
musicType = Out.ObjectType "Music" Nothing [] musicType = Out.ObjectType "Music" Nothing []
$ HashMap.fromList resolvers $ HashMap.fromList resolvers
where where
@@ -92,7 +95,7 @@ musicType = Out.ObjectType "Music" Nothing []
instrumentResolver = pure $ String "piano" instrumentResolver = pure $ String "piano"
instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
poetryType :: Out.ObjectType (Either SomeException) poetryType :: Out.ObjectType IO
poetryType = Out.ObjectType "Poetry" Nothing [] poetryType = Out.ObjectType "Poetry" Nothing []
$ HashMap.fromList resolvers $ HashMap.fromList resolvers
where where
@@ -102,10 +105,10 @@ poetryType = Out.ObjectType "Poetry" Nothing []
genreResolver = pure $ String "Futurism" genreResolver = pure $ String "Futurism"
genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty 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] interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
philosopherType :: Out.ObjectType (Either SomeException) philosopherType :: Out.ObjectType IO
philosopherType = Out.ObjectType "Philosopher" Nothing [] philosopherType = Out.ObjectType "Philosopher" Nothing []
$ HashMap.fromList resolvers $ HashMap.fromList resolvers
where where
@@ -146,14 +149,14 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
firstLanguageResolver = pure Null firstLanguageResolver = pure Null
workType :: Out.InterfaceType (Either SomeException) workType :: Out.InterfaceType IO
workType = Out.InterfaceType "Work" Nothing [] workType = Out.InterfaceType "Work" Nothing []
$ HashMap.fromList fields $ HashMap.fromList fields
where where
fields = [("title", titleField)] fields = [("title", titleField)]
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
bookType :: Out.ObjectType (Either SomeException) bookType :: Out.ObjectType IO
bookType = Out.ObjectType "Book" Nothing [workType] bookType = Out.ObjectType "Book" Nothing [workType]
$ HashMap.fromList resolvers $ HashMap.fromList resolvers
where where
@@ -163,7 +166,7 @@ bookType = Out.ObjectType "Book" Nothing [workType]
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen" 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] bookCollectionType = Out.ObjectType "Book" Nothing [workType]
$ HashMap.fromList resolvers $ HashMap.fromList resolvers
where where
@@ -173,7 +176,7 @@ bookCollectionType = Out.ObjectType "Book" Nothing [workType]
titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
titleResolver = pure "The Three Critiques" titleResolver = pure "The Three Critiques"
subscriptionType :: Out.ObjectType (Either SomeException) subscriptionType :: Out.ObjectType IO
subscriptionType = Out.ObjectType "Subscription" Nothing [] subscriptionType = Out.ObjectType "Subscription" Nothing []
$ HashMap.singleton "newQuote" $ HashMap.singleton "newQuote"
$ EventStreamResolver quoteField (pure $ Object mempty) $ EventStreamResolver quoteField (pure $ Object mempty)
@@ -182,7 +185,7 @@ subscriptionType = Out.ObjectType "Subscription" Nothing []
quoteField = quoteField =
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
quoteType :: Out.ObjectType (Either SomeException) quoteType :: Out.ObjectType IO
quoteType = Out.ObjectType "Quote" Nothing [] quoteType = Out.ObjectType "Quote" Nothing []
$ HashMap.singleton "quote" $ HashMap.singleton "quote"
$ ValueResolver quoteField $ ValueResolver quoteField
@@ -207,12 +210,40 @@ shouldResolveTo :: Text.Text -> Response Type.Value -> Expectation
shouldResolveTo querySource expected = shouldResolveTo querySource expected =
case parse document "" querySource of case parse document "" querySource of
(Right parsedDocument) -> (Right parsedDocument) ->
case execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) parsedDocument of execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) parsedDocument >>= go
Right (Right result) -> shouldBe result expected
Right (Left _) -> expectationFailure
"the query is expected to resolve to a value, but it resolved to an event stream"
Left executionError -> throwIO executionError
(Left errorBundle) -> expectationFailure $ errorBundlePretty errorBundle (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 :: Spec
spec = spec =
@@ -347,30 +378,18 @@ spec =
context "queryError" $ do context "queryError" $ do
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }" let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
twoQueries = namedQuery "A" <> " " <> namedQuery "B" 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" $ it "throws operation name is required error" $ do
let expectedErrorMessage :: Text.Text let expectedErrorMessage = "Operation name is required"
expectedErrorMessage = "Operation name is required" actual <- parseAndExecute philosopherSchema Nothing mempty twoQueries
execute' :: Document -> Either SomeException EitherStreamOrValue actual `shouldContainError` expectedErrorMessage
execute' = execute philosopherSchema Nothing (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" $ it "throws operation not found error" $ do
let expectedErrorMessage :: Text.Text let expectedErrorMessage = "Operation \"C\" is not found"
expectedErrorMessage = "Operation \"C\" is not found" actual <- parseAndExecute philosopherSchema (Just "C") mempty twoQueries
execute' :: Document -> Either SomeException EitherStreamOrValue actual `shouldContainError` expectedErrorMessage
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" $ it "throws variable coercion error" $ do
let data'' = Null let data'' = Null
executionErrors = pure $ Error executionErrors = pure $ Error
{ message = "Failed to coerce the variable $id: String." { message = "Failed to coerce the variable $id: String."
@@ -378,11 +397,10 @@ spec =
, path = [] , path = []
} }
expected = Response data'' executionErrors expected = Response data'' executionErrors
executeWithVars :: Document -> Either SomeException EitherStreamOrValue
executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1)) executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
Right (Right actual) = either (pure . parseError) executeWithVars Right actual <- either (pure . parseError) executeWithVars
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }" $ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
in actual `shouldBe` expected actual `shouldBe` expected
it "throws variable unkown input type error" $ it "throws variable unkown input type error" $
let data'' = Null let data'' = Null
@@ -408,17 +426,15 @@ spec =
in path' `shouldBe` expected in path' `shouldBe` expected
context "Subscription" $ context "Subscription" $
it "subscribes" $ it "subscribes" $ do
let data'' = Object let data'' = Object
$ HashMap.singleton "newQuote" $ HashMap.singleton "newQuote"
$ Object $ Object
$ HashMap.singleton "quote" $ HashMap.singleton "quote"
$ String "Naturam expelles furca, tamen usque recurret." $ String "Naturam expelles furca, tamen usque recurret."
expected = Response data'' mempty expected = Response data'' mempty
Left stream Left stream <- execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
= fromRight (error "Execution error") $ fromRight (error "Parse error")
$ execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) $ parse document "" "subscription { newQuote { quote } }"
$ fromRight (error "Parse error") Just actual <- runConduit $ stream .| await
$ parse document "" "subscription { newQuote { quote } }" actual `shouldBe` expected
Right (Just actual) = runConduit $ stream .| await
in actual `shouldBe` expected