Variable definitions validation

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
 

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

@@ -33,9 +33,11 @@ module GraphQL.Internal.Schema
   , NonNullType(..)
   , DefinesTypes(..)
   , doesFragmentTypeApply
+  , getInputTypeDefinition
   -- * The schema
   , Schema
   , makeSchema
+  , emptySchema
   , lookupType
   ) where
 
@@ -58,6 +60,9 @@ newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show)
 makeSchema :: ObjectTypeDefinition -> Schema
 makeSchema = Schema . getDefinedTypes
 
+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
@@ -301,3 +306,14 @@ 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

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

@@ -81,6 +81,13 @@ import GraphQL.Internal.Schema
   , Schema
   , doesFragmentTypeApply
   , lookupType
+  , AnnotatedType(..)
+  , InputType
+  , InputType (BuiltinInputType, DefinedInputType) 
+  , Builtin (..)
+  , AnnotatedType (TypeNamed, TypeNonNull)
+  , NonNullType(NonNullTypeNamed)
+  , getInputTypeDefinition
   )
 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,8 @@ 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 :: 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 +650,47 @@ 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) =
+  case validateTypeAssertion schema var varType of
+    Left e -> throwE e 
+    Right t -> VariableDefinition var t <$> traverse validateDefaultValue value
+
+-- | Ensure that a variable has a correct type declaration given a schema.
+validateTypeAssertion :: Schema -> Variable -> AST.GType -> Either ValidationError (AnnotatedType InputType)
+validateTypeAssertion schema var varTypeAST = 
+  case typeDef of
+    Nothing -> fmap (astAnnotationToSchemaAnnotation varTypeAST) (validateVariableTypeBuiltin var varTypeNameAST) 
+    Just value -> astAnnotationToSchemaAnnotation varTypeAST . DefinedInputType <$> maybeToEither (VariableTypeIsNotInputType var varTypeNameAST) (getInputTypeDefinition value)
+  where 
+    varTypeNameAST = getName varTypeAST
+    typeDef = lookupType schema varTypeNameAST
+
+-- | validate a variable type which has no type definition (either builtin or not in the schema)
+validateVariableTypeBuiltin :: Variable -> Name -> Either ValidationError InputType
+validateVariableTypeBuiltin var tname
+  | tname == getName GInt = Right (BuiltinInputType GInt)
+  | tname == getName GBool = Right (BuiltinInputType GBool)
+  | tname == getName GString = Right (BuiltinInputType GString)
+  | tname == getName GFloat = Right (BuiltinInputType GFloat)
+  | tname == getName GID = Right (BuiltinInputType GID)
+  | otherwise = Left (VariableTypeNotFound var tname)
+
+-- | simple translation between ast annotation types and schema annotation types
+astAnnotationToSchemaAnnotation :: AST.GType -> a -> AnnotatedType a
+astAnnotationToSchemaAnnotation gtype schematn = 
+  case gtype of
+    AST.TypeNamed _ -> TypeNamed schematn
+    AST.TypeList (AST.ListType asttn) -> astAnnotationToSchemaAnnotation asttn schematn
+    AST.TypeNonNull (AST.NonNullTypeNamed _) -> TypeNonNull (NonNullTypeNamed schematn)
+    AST.TypeNonNull (AST.NonNullTypeList (AST.ListType asttn)) -> astAnnotationToSchemaAnnotation asttn schematn
 
 -- | Ensure that a default value contains no variables.
 validateDefaultValue :: AST.DefaultValue -> Validation Value
@@ -776,6 +815,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 +842,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
 

tests/ValidationTests.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
 
 -- | Tests for query validation.
 module ValidationTests (tests) where
@@ -11,8 +12,9 @@ import Test.Tasty (TestTree)
 import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)
 
 import GraphQL.Internal.Name (Name)
+import qualified Data.Map as Map
 import qualified GraphQL.Internal.Syntax.AST as AST
-import GraphQL.Internal.Schema (Schema)
+import GraphQL.Internal.Schema (Schema, emptySchema)
 import GraphQL.Internal.Validation
   ( ValidationError(..)
   , findDuplicates
@@ -27,11 +29,11 @@ someName = "name"
 
 dog :: Name
 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