Eliminate non-exhaustive patterns in ExecuteSpec
This commit is contained in:
parent
2f19093803
commit
2321d1a1bc
GPG Key ID:
A27FDC1E8EE902C0
@ -3,7 +3,9 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
@ -11,7 +13,7 @@ module Language.GraphQL.ExecuteSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Control.Exception (Exception(..), SomeException, throwIO)
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Data.Conduit
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
@ -33,6 +35,7 @@ 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
|
||||
@ -49,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
|
||||
@ -59,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)
|
||||
@ -75,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
|
||||
@ -92,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
|
||||
@ -102,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
|
||||
@ -146,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
|
||||
@ -163,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
|
||||
@ -173,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)
|
||||
@ -182,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
|
||||
@ -207,12 +210,40 @@ shouldResolveTo :: Text.Text -> Response Type.Value -> Expectation
|
||||
shouldResolveTo querySource expected =
|
||||
case parse document "" querySource of
|
||||
(Right parsedDocument) ->
|
||||
case execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value) parsedDocument of
|
||||
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
|
||||
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 =
|
||||
@ -347,30 +378,18 @@ spec =
|
||||
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"
|
||||
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||
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 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."
|
||||
@ -378,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
|
||||
@ -408,17 +426,15 @@ spec =
|
||||
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
|
||||
Left stream
|
||||
= fromRight (error "Execution error")
|
||||
$ execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
|
||||
$ fromRight (error "Parse error")
|
||||
$ 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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user