Merge pull request #186 from theobat/variable-definitions-validation

Variable definitions validation

Author: jml

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
 

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,
 }
 
 

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

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,14 +168,19 @@ 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)
 
 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 <http://facebook.github.io/graphql/June2018/#sec-Input-and-Output-Types>
+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)))

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)

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.
+  -- <http://facebook.github.io/graphql/June2018/#sec-Variables-Are-Input-Types>
+  | 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)