diff --git a/graphql-api.cabal b/graphql-api.cabal index 3628830..5450b8b 100644 --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -1,8 +1,8 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: 6a38b887cec0d4a157469f5d73041fd16cb286d8f445f4e213c6f08965dbc563 +-- hash: 6db006b020fe198ac64b8a50f8335017251389b7c34dfc553675e38eb001a428 name: graphql-api version: 0.3.0 @@ -23,7 +23,6 @@ license: Apache license-file: LICENSE.Apache-2.0 build-type: Simple cabal-version: >= 1.10 - extra-source-files: CHANGELOG.rst diff --git a/scripts/hpc-ratchet b/scripts/hpc-ratchet index e2332af..4eeace0 100755 --- a/scripts/hpc-ratchet +++ b/scripts/hpc-ratchet @@ -35,11 +35,11 @@ In a just world, this would be a separate config file, or command-line arguments Each item represents the number of "things" we are OK with not being covered. """ COVERAGE_TOLERANCE = { - ALTERNATIVES: 175, + ALTERNATIVES: 161, BOOLEANS: 8, - EXPRESSIONS: 1494, - LOCAL_DECLS: 15, - TOP_LEVEL_DECLS: 685, + EXPRESSIONS: 1416, + LOCAL_DECLS: 14, + TOP_LEVEL_DECLS: 669, } diff --git a/src/GraphQL/Internal/Execution.hs b/src/GraphQL/Internal/Execution.hs index 074aa8e..714a212 100644 --- a/src/GraphQL/Internal/Execution.hs +++ b/src/GraphQL/Internal/Execution.hs @@ -28,13 +28,15 @@ import GraphQL.Value , Object'(..) ) import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Schema + ( AnnotatedType (TypeNonNull) + ) import GraphQL.Internal.Validation ( Operation , QueryDocument(..) , VariableDefinition(..) , VariableValue , Variable - , GType(..) ) -- | Get an operation from a GraphQL document diff --git a/src/GraphQL/Internal/Schema.hs b/src/GraphQL/Internal/Schema.hs index 59b7cdd..21cd8b7 100644 --- a/src/GraphQL/Internal/Schema.hs +++ b/src/GraphQL/Internal/Schema.hs @@ -22,6 +22,7 @@ module GraphQL.Internal.Schema , InterfaceTypeDefinition(..) , ObjectTypeDefinition(..) , UnionTypeDefinition(..) + , ScalarTypeDefinition(..) -- ** Input types , InputType(..) , InputTypeDefinition(..) @@ -33,15 +34,20 @@ module GraphQL.Internal.Schema , NonNullType(..) , DefinesTypes(..) , doesFragmentTypeApply + , getInputTypeDefinition + , builtinFromName + , astAnnotationToSchemaAnnotation -- * The schema , Schema , makeSchema + , emptySchema , lookupType ) where import Protolude import qualified Data.Map as Map +import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Value (Value) import GraphQL.Internal.Name (HasName(..), Name) @@ -58,6 +64,11 @@ newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show) makeSchema :: ObjectTypeDefinition -> Schema makeSchema = Schema . getDefinedTypes +-- | Create an empty schema for testing purpose. +-- +emptySchema :: Schema +emptySchema = Schema (Map.empty :: (Map Name TypeDefinition)) + -- | Find the type with the given name in the schema. lookupType :: Schema -> Name -> Maybe TypeDefinition lookupType (Schema schema) name = Map.lookup name schema @@ -157,7 +168,9 @@ instance HasName FieldDefinition where getName (FieldDefinition name _ _) = name instance DefinesTypes FieldDefinition where - getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal) + getDefinedTypes (FieldDefinition _ args retVal) = + getDefinedTypes (getAnnotatedType retVal) <> + foldMap getDefinedTypes args data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) deriving (Eq, Ord, Show) @@ -165,6 +178,9 @@ data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (May instance HasName ArgumentDefinition where getName (ArgumentDefinition name _ _) = name +instance DefinesTypes ArgumentDefinition where + getDefinedTypes (ArgumentDefinition _ annotatedType _) = getDefinedTypes $ getAnnotatedType annotatedType + data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmpty FieldDefinition) deriving (Eq, Ord, Show) @@ -256,6 +272,12 @@ instance HasName InputType where getName (DefinedInputType x) = getName x getName (BuiltinInputType x) = getName x +instance DefinesTypes InputType where + getDefinedTypes inputType = + case inputType of + DefinedInputType typeDefinition -> getDefinedTypes typeDefinition + BuiltinInputType _ -> mempty + data InputTypeDefinition = InputTypeDefinitionObject InputObjectTypeDefinition | InputTypeDefinitionScalar ScalarTypeDefinition @@ -267,6 +289,13 @@ instance HasName InputTypeDefinition where getName (InputTypeDefinitionScalar x) = getName x getName (InputTypeDefinitionEnum x) = getName x +instance DefinesTypes InputTypeDefinition where + getDefinedTypes inputTypeDefinition = + case inputTypeDefinition of + InputTypeDefinitionObject typeDefinition -> getDefinedTypes (TypeDefinitionInputObject typeDefinition) + InputTypeDefinitionScalar typeDefinition -> getDefinedTypes (TypeDefinitionScalar typeDefinition) + InputTypeDefinitionEnum typeDefinition -> getDefinedTypes (TypeDefinitionEnum typeDefinition) + -- | A literal value specified as a default as part of a type definition. -- -- Use this type alias when you want to be clear that a definition may include @@ -301,3 +330,39 @@ doesFragmentTypeApply objectType fragmentType = where implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces branchOf obj (UnionTypeDefinition _ branches) = obj `elem` branches + +-- | Convert the given 'TypeDefinition' to an 'InputTypeDefinition' if it's a valid 'InputTypeDefinition' +-- (because 'InputTypeDefinition' is a subset of 'TypeDefinition') +-- see +getInputTypeDefinition :: TypeDefinition -> Maybe InputTypeDefinition +getInputTypeDefinition td = + case td of + TypeDefinitionInputObject itd -> Just (InputTypeDefinitionObject itd) + TypeDefinitionScalar itd -> Just (InputTypeDefinitionScalar itd) + TypeDefinitionEnum itd -> Just (InputTypeDefinitionEnum itd) + _ -> Nothing + +-- | Create a 'Builtin' type from a 'Name' +-- +-- Mostly used for the AST validation +-- theobat: There's probably a better way to do it but can't find it right now +builtinFromName :: Name -> Maybe Builtin +builtinFromName typeName + | typeName == getName GInt = Just GInt + | typeName == getName GBool = Just GBool + | typeName == getName GString = Just GString + | typeName == getName GFloat = Just GFloat + | typeName == getName GID = Just GID + | otherwise = Nothing + +-- | Simple translation between 'AST' annotation types and 'Schema' annotation types +-- +-- AST type annotations do not need any validation. +-- GraphQL annotations are semantic decorations around type names to indicate type composition (list/non null). +astAnnotationToSchemaAnnotation :: AST.GType -> a -> AnnotatedType a +astAnnotationToSchemaAnnotation gtype schemaTypeName = + case gtype of + AST.TypeNamed _ -> TypeNamed schemaTypeName + AST.TypeList (AST.ListType astTypeName) -> TypeList (ListType $ astAnnotationToSchemaAnnotation astTypeName schemaTypeName) + AST.TypeNonNull (AST.NonNullTypeNamed _) -> TypeNonNull (NonNullTypeNamed schemaTypeName) + AST.TypeNonNull (AST.NonNullTypeList (AST.ListType astTypeName)) -> TypeNonNull (NonNullTypeList (ListType (astAnnotationToSchemaAnnotation astTypeName schemaTypeName))) diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs index 9e88d4a..23d6aaf 100644 --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -53,8 +53,11 @@ import Protolude import Test.QuickCheck (Arbitrary(..), listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) -import GraphQL.Internal.Name (Name) - +import GraphQL.Internal.Name + ( Name + , HasName(..) + ) + -- * Documents -- | A 'QueryDocument' is something a user might send us. @@ -176,6 +179,13 @@ data GType = TypeNamed NamedType | TypeNonNull NonNullType deriving (Eq, Ord, Show) +-- | Get the name of the given 'GType'. +instance HasName GType where + getName (TypeNamed (NamedType n)) = n + getName (TypeList (ListType t)) = getName t + getName (TypeNonNull (NonNullTypeNamed (NamedType n))) = n + getName (TypeNonNull (NonNullTypeList (ListType l))) = getName l + newtype NamedType = NamedType Name deriving (Eq, Ord, Show) newtype ListType = ListType GType deriving (Eq, Ord, Show) diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs index dad4dd4..88e02e1 100644 --- a/src/GraphQL/Internal/Validation.hs +++ b/src/GraphQL/Internal/Validation.hs @@ -58,6 +58,7 @@ module GraphQL.Internal.Validation , getResponseKey -- * Exported for testing , findDuplicates + , formatErrors ) where import Protolude hiding ((<>), throwE) @@ -81,6 +82,12 @@ import GraphQL.Internal.Schema , Schema , doesFragmentTypeApply , lookupType + , AnnotatedType(..) + , InputType (BuiltinInputType, DefinedInputType) + , AnnotatedType + , getInputTypeDefinition + , builtinFromName + , astAnnotationToSchemaAnnotation ) import GraphQL.Value ( Value @@ -174,7 +181,7 @@ validateOperations schema fragments ops = do traverse validateNode deduped where validateNode (operationType, AST.Node _ vars directives ss) = - operationType <$> lift (validateVariableDefinitions vars) + operationType <$> lift (validateVariableDefinitions schema vars) <*> lift (validateDirectives directives) <*> validateSelectionSet schema fragments ss @@ -626,7 +633,7 @@ validateArguments args = Arguments <$> mapErrors DuplicateArgument (makeMap [(na data VariableDefinition = VariableDefinition { variable :: Variable -- ^ The name of the variable - , variableType :: AST.GType -- ^ The type of the variable + , variableType :: AnnotatedType InputType -- ^ The type of the variable , defaultValue :: Maybe Value -- ^ An optional default value for the variable } deriving (Eq, Ord, Show) @@ -642,16 +649,43 @@ emptyVariableDefinitions :: VariableDefinitions emptyVariableDefinitions = mempty -- | Ensure that a set of variable definitions is valid. -validateVariableDefinitions :: [AST.VariableDefinition] -> Validation VariableDefinitions -validateVariableDefinitions vars = do - validatedDefns <- traverse validateVariableDefinition vars +validateVariableDefinitions :: Schema -> [AST.VariableDefinition] -> Validation VariableDefinitions +validateVariableDefinitions schema vars = do + validatedDefns <- traverse (validateVariableDefinition schema) vars let items = [ (variable defn, defn) | defn <- validatedDefns] mapErrors DuplicateVariableDefinition (makeMap items) -- | Ensure that a variable definition is a valid one. -validateVariableDefinition :: AST.VariableDefinition -> Validation VariableDefinition -validateVariableDefinition (AST.VariableDefinition name varType value) = - VariableDefinition name varType <$> traverse validateDefaultValue value +validateVariableDefinition :: Schema -> AST.VariableDefinition -> Validation VariableDefinition +validateVariableDefinition schema (AST.VariableDefinition var varType value) = + VariableDefinition var + <$> validateTypeAssertion schema var varType + <*> traverse validateDefaultValue value + +-- | Ensure that a variable has a correct type declaration given a schema. +validateTypeAssertion :: Schema -> Variable -> AST.GType -> Validation (AnnotatedType InputType) +validateTypeAssertion schema var varTypeAST = + astAnnotationToSchemaAnnotation varTypeAST <$> + case lookupType schema varTypeNameAST of + Nothing -> validateVariableTypeBuiltin var varTypeNameAST + Just cleanTypeDef -> validateVariableTypeDefinition var cleanTypeDef + where + varTypeNameAST = getName varTypeAST + +-- | Validate a variable type which has a type definition in the schema. +validateVariableTypeDefinition :: Variable -> TypeDefinition -> Validation InputType +validateVariableTypeDefinition var typeDef = + case getInputTypeDefinition typeDef of + Nothing -> throwE (VariableTypeIsNotInputType var $ getName typeDef) + Just value -> pure (DefinedInputType value) + + +-- | Validate a variable type which has no type definition (either builtin or not in the schema). +validateVariableTypeBuiltin :: Variable -> Name -> Validation InputType +validateVariableTypeBuiltin var typeName = + case builtinFromName typeName of + Nothing -> throwE (VariableTypeNotFound var typeName) + Just builtin -> pure (BuiltinInputType builtin) -- | Ensure that a default value contains no variables. validateDefaultValue :: AST.DefaultValue -> Validation Value @@ -776,6 +810,11 @@ data ValidationError | IncompatibleFields Name -- | There's a type condition that's not present in the schema. | TypeConditionNotFound Name + -- | There's a variable type that's not present in the schema. + | VariableTypeNotFound Variable Name + -- | A variable was defined with a non input type. + -- + | VariableTypeIsNotInputType Variable Name deriving (Eq, Show) instance GraphQLError ValidationError where @@ -798,6 +837,8 @@ instance GraphQLError ValidationError where formatError (MismatchedArguments name) = "Two different sets of arguments given for same response key: " <> show name formatError (IncompatibleFields name) = "Field " <> show name <> " has a leaf in one place and a non-leaf in another." formatError (TypeConditionNotFound name) = "Type condition " <> show name <> " not found in schema." + formatError (VariableTypeNotFound var name) = "Type named " <> show name <> " for variable " <> show var <> " is not in the schema." + formatError (VariableTypeIsNotInputType var name) = "Type named " <> show name <> " for variable " <> show var <> " is not an input type." type ValidationErrors = NonEmpty ValidationError @@ -841,6 +882,11 @@ makeMap entries = -- * Error handling +-- | Utility function for tests, format ErrorTypes to their text representation +-- returns a list of error messages +formatErrors :: [ValidationError] -> [Text] +formatErrors errors = formatError <$> errors + -- | A 'Validator' is a value that can either be valid or have a non-empty -- list of errors. newtype Validator e a = Validator { runValidator :: Either (NonEmpty e) a } deriving (Eq, Show, Functor, Monad) diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs index ab8019b..1f39818 100644 --- a/tests/ASTTests.hs +++ b/tests/ASTTests.hs @@ -115,6 +115,16 @@ tests = testSpec "AST" $ do ] parsed `shouldBe` expected + it "errors on missing selection set" $ do + let query = [r|query { + dog { + + } + }|] + let Left parsed = parseOnly Parser.queryDocument query + -- this is not very explicit + parsed `shouldBe` "query document error! > definition error!: string" + it "parses invalid documents" $ do let query = [r|{ dog { @@ -211,3 +221,98 @@ tests = testSpec "AST" $ do ])) ] parsed `shouldBe` expected + it "parses anonymous query with variable annotation" $ do + let query = [r| + query ($atOtherHomes: [Home!]) { + dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeList + (AST.ListType + (AST.TypeNonNull + (AST.NonNullTypeNamed (AST.NamedType "Home")) + ) + ) + ) + Nothing + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + it "parses anonymous query with inline argument (List, Object, Enum, String, Number)" $ do + -- keys are not quoted for inline objects + let query = [r| + query { + dog { + isHousetrained(atOtherHomes: [{testKey: 123, anotherKey: "string"}]) + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueList (AST.ListValue [ + (AST.ValueObject (AST.ObjectValue [ + (AST.ObjectField "testKey" (AST.ValueInt 123)), + (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) + ])) + ])) + ] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + it "parses anonymous query with fragment" $ do + -- keys are not quoted for inline objects + let query = [r| + fragment dogTest on Dog { + name + } + query { + dog { + ...dogTest + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" + (AST.NamedType "Dog") [] [ + AST.SelectionField (AST.Field Nothing "name" [] [] []) + ])), + (AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [] [] + [AST.SelectionField + (AST.Field Nothing dog [] [] + [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) + ]) + ]))) + ] + parsed `shouldBe` expected diff --git a/tests/EndToEndTests.hs b/tests/EndToEndTests.hs index 5790251..872c6fa 100644 --- a/tests/EndToEndTests.hs +++ b/tests/EndToEndTests.hs @@ -377,8 +377,27 @@ tests = testSpec "End-to-end tests" $ do } } |] - it "Errors when no variables provided" $ do - response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing mempty + let Right annotatedQuery = + compileQuery schema + [r|query myQuery($whichCommand: DogCommand!) { + dog { + name + doesKnowCommand(dogCommand: $whichCommand) + } + } + |] + let Right badQuery = + compileQuery schema + [r|query myQuery($whichCommand: String!) { + dog { + name + doesKnowCommand(dogCommand: $whichCommand) + } + } + |] + it "Errors when variable and argument types are in conflict" $ do + let vars = Map.singleton (Variable "whichCommand") $ toValue @Text "cow" + response <- executeQuery @QueryRoot (rootHandler mortgage) badQuery Nothing vars let expected = object [ "data" .= object @@ -394,6 +413,24 @@ tests = testSpec "End-to-end tests" $ do -- a typeclass for client-friendly "Show" (separate from -- actual Show which remains extremely useful for debugging) -- and use that when including values in error messages. + [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' (ConstString (String \"cow\")) not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Errors when no variables provided" $ do + response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= Null + ] + ] + , "errors" .= + [ + object [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) ] ] @@ -419,3 +456,30 @@ tests = testSpec "End-to-end tests" $ do ] ] toJSON (toValue response) `shouldBe` expected + it "Substitutes annotated variables when they are provided" $ do + let Right varName = makeName "whichCommand" + let vars = Map.singleton (Variable varName) (toValue Sit) + response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing vars + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= False + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Errors when non-null variable is not provided" $ do + response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing mempty + let expected = + object + [ "data" .= Null + , "errors" .= + [ + object + [ "message" .= ("Execution error: MissingValue (Variable (Name {unName = \"whichCommand\"}))" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected diff --git a/tests/SchemaTests.hs b/tests/SchemaTests.hs index 53717af..f12de4f 100644 --- a/tests/SchemaTests.hs +++ b/tests/SchemaTests.hs @@ -14,6 +14,7 @@ import GraphQL.API , getAnnotatedInputType , getDefinition ) +import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.API ( getAnnotatedType , getFieldDefinition @@ -30,9 +31,17 @@ import GraphQL.Internal.Schema , UnionTypeDefinition(..) , GType(..) , TypeDefinition(..) + , InputTypeDefinition(..) + , InputObjectTypeDefinition(..) + , InputObjectFieldDefinition(..) + , ScalarTypeDefinition(..) + , AnnotatedType(..) , NonNullType(..) , Builtin(..) , InputType(..) + , getInputTypeDefinition + , builtinFromName + , astAnnotationToSchemaAnnotation ) import ExampleSchema @@ -72,3 +81,53 @@ tests = testSpec "Type" $ do it "encodes correctly" $ do getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))) getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt))))) + describe "TypeDefinition accepted as InputTypes" $ + it "Enum/InputObject/Scalar" $ do + getInputTypeDefinition (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" + [ EnumValueDefinition "Sit" + , EnumValueDefinition "Down" + , EnumValueDefinition "Heel" + ])) `shouldBe` Just (InputTypeDefinitionEnum (EnumTypeDefinition "DogCommand" + [ EnumValueDefinition "Sit" + , EnumValueDefinition "Down" + , EnumValueDefinition "Heel" + ])) + getInputTypeDefinition (TypeDefinitionInputObject (InputObjectTypeDefinition "Human" + (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) + )) `shouldBe` Just (InputTypeDefinitionObject (InputObjectTypeDefinition "Human" + (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) + )) + getInputTypeDefinition (TypeDefinitionScalar (ScalarTypeDefinition "Human")) `shouldBe` Just (InputTypeDefinitionScalar (ScalarTypeDefinition "Human")) + describe "TypeDefinition refused as InputTypes" $ + -- todo: add all the others (union type, ..?) + it "Object" $ do + getInputTypeDefinition (TypeDefinitionObject (ObjectTypeDefinition "Human" [] + (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))) `shouldBe` Nothing + describe "Builtin types from name" $ + it "Int/Bool/String/Float/ID" $ do + builtinFromName "Int" `shouldBe` Just GInt + builtinFromName "Boolean" `shouldBe` Just GBool + builtinFromName "String" `shouldBe` Just GString + builtinFromName "Float" `shouldBe` Just GFloat + builtinFromName "ID" `shouldBe` Just GID + builtinFromName "RANDOMSTRING" `shouldBe` Nothing + describe "Annotations from AST" $ + it "annotation like [[ScalarType!]]!" $ do + let typeDefinitionScalar = (TypeDefinitionScalar (ScalarTypeDefinition "ScalarType")) + astAnnotationToSchemaAnnotation ( + AST.TypeNonNull ( + AST.NonNullTypeList ( + AST.ListType ( + AST.TypeList ( + AST.ListType ( + AST.TypeNonNull ( + AST.NonNullTypeNamed (AST.NamedType "ScalarType") + ))))))) typeDefinitionScalar `shouldBe` ( + TypeNonNull ( + NonNullTypeList ( + ListType ( + TypeList ( + ListType ( + TypeNonNull ( + NonNullTypeNamed typeDefinitionScalar + ))))))) \ No newline at end of file diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs index 25ab059..ef76764 100644 --- a/tests/ValidationTests.hs +++ b/tests/ValidationTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} -- | Tests for query validation. module ValidationTests (tests) where @@ -9,14 +10,16 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ((===)) import Test.Tasty (TestTree) import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) +import qualified Data.Set as Set import GraphQL.Internal.Name (Name) import qualified GraphQL.Internal.Syntax.AST as AST -import GraphQL.Internal.Schema (Schema) +import GraphQL.Internal.Schema (emptySchema, Schema) import GraphQL.Internal.Validation ( ValidationError(..) , findDuplicates , getErrors + , formatErrors ) me :: Maybe Name @@ -31,7 +34,7 @@ dog = "dog" -- | Schema used for these tests. Since none of them do type-level stuff, we -- don't need to define it. schema :: Schema -schema = panic "schema evaluated. We weren't expecting that." +schema = emptySchema tests :: IO TestTree tests = testSpec "Validation" $ do @@ -52,7 +55,7 @@ tests = testSpec "Validation" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation (AST.Query - (AST.Node (Nothing) [] [] + (AST.Node Nothing [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField (AST.Field Nothing someName [] [] []) @@ -82,6 +85,29 @@ tests = testSpec "Validation" $ do ])) ] getErrors schema doc `shouldBe` [] + it "Treats anonymous queries with annotated variables as valid ([[Boolean]]!)" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNonNull (AST.NonNullTypeList (AST.ListType + (AST.TypeList (AST.ListType (AST.TypeNamed (AST.NamedType "Boolean")))) + ))) + Nothing + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] it "Detects duplicate operation names" $ do let doc = AST.QueryDocument @@ -115,7 +141,108 @@ tests = testSpec "Validation" $ do ] ) ] - getErrors schema doc `shouldBe` [MixedAnonymousOperations 2 []] + let errors = getErrors schema doc + errors `shouldBe` [MixedAnonymousOperations 2 []] + formatErrors errors `shouldBe` ["Multiple anonymous operations defined. Found 2"] + + it "Detects mixed operations" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.AnonymousQuery + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + , AST.DefinitionOperation + ( AST.Query (AST.Node (pure "houseTrainedQuery") [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + )) + ] + let errors = getErrors schema doc + errors `shouldBe` [MixedAnonymousOperations 1 [Just "houseTrainedQuery"]] + formatErrors errors `shouldBe` ["Document contains both anonymous operations (1) and named operations ([Just (Name {unName = \"houseTrainedQuery\"})])"] + + it "Detects non-existing type in variable definition" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "MyNonExistingType")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [VariableTypeNotFound (AST.Variable "atOtherHomes") "MyNonExistingType"] + + it "Detects unused variable definition" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "String")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [UnusedVariables (Set.fromList [AST.Variable "atOtherHomes"])] + + it "Treats anonymous queries with inline arguments as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueList (AST.ListValue [ + (AST.ValueObject (AST.ObjectValue [ + (AST.ObjectField "testKey" (AST.ValueInt 123)), + (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) + ])) + ])) + ] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] + it "Detects non-existent fragment type" $ do + let doc = AST.QueryDocument + [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" + (AST.NamedType "Dog") [] [ + AST.SelectionField (AST.Field Nothing "name" [] [] []) + ])), + (AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [] [] + [AST.SelectionField + (AST.Field Nothing dog [] [] + [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) + ]) + ]))) + ] + getErrors schema doc `shouldBe` [TypeConditionNotFound "Dog"] describe "findDuplicates" $ do prop "returns empty on unique lists" $ do