diff options
Diffstat (limited to 'tests/Language')
| -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 |
3 files changed, 238 insertions, 42 deletions
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 |