From 2f19093803f8d852e1488dc112ae4aa9d0fcb212 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 1 Jul 2022 12:18:02 +0200 Subject: [PATCH] Change execute' to shouldResolveTo helper method --- graphql.cabal | 1 + src/Language/GraphQL/AST/Encoder.hs | 2 +- src/Language/GraphQL/Validate/Rules.hs | 6 +- tests/Language/GraphQL/ExecuteSpec.hs | 109 +++++++++++++------------ 4 files changed, 63 insertions(+), 55 deletions(-) diff --git a/graphql.cabal b/graphql.cabal index 0dd16b2..3cc6160 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 0d448df..4569823 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -101,7 +101,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 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/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 73d62b4..6c31455 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -2,6 +2,8 @@ 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 NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -9,7 +11,7 @@ module Language.GraphQL.ExecuteSpec ( spec ) where -import Control.Exception (Exception(..), SomeException) +import Control.Exception (Exception(..), SomeException, throwIO) import Control.Monad.Catch (throwM) import Data.Conduit import Data.HashMap.Strict (HashMap) @@ -27,11 +29,16 @@ 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 qualified Data.Text as Text +import Test.Hspec.Expectations + ( Expectation + , expectationFailure + ) +import Data.Either (fromRight) data PhilosopherException = PhilosopherException deriving Show @@ -195,9 +202,17 @@ type EitherStreamOrValue = Either (ResponseEventStream (Either SomeException) 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) -> + 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 + (Left errorBundle) -> expectationFailure $ errorBundlePretty errorBundle spec :: Spec spec = @@ -213,9 +228,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 +238,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 +249,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 +261,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 +273,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 +286,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 +298,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 +309,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 +320,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 +330,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,30 +341,31 @@ 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 + 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 + 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 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'' + 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 @@ -387,9 +392,8 @@ 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 @@ -411,7 +415,10 @@ spec = $ HashMap.singleton "quote" $ String "Naturam expelles furca, tamen usque recurret." expected = Response data'' mempty - Right (Left stream) = either (pure . parseError) execute' + 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