Validate fragments are input types

CHANGELOG.md

@@ -42,6 +42,7 @@ and this project adheres to
   - `uniqueArgumentNamesRule`
   - `uniqueDirectiveNamesRule`
   - `uniqueVariableNamesRule`
+  - `variablesAreInputTypesRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.

src/Language/GraphQL/Execute/Transform.hs

@@ -47,7 +47,6 @@ import Language.GraphQL.AST (Name)
 import qualified Language.GraphQL.Execute.Coerce as Coerce
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type as Type
-import qualified Language.GraphQL.Type.In as In
 import Language.GraphQL.Type.Internal
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
@@ -139,35 +138,6 @@ getOperation (Just operationName) operations
     matchingName (OperationDefinition _ name _ _ _) =
         name == Just operationName
 
-lookupInputType
-    :: Full.Type
-    -> HashMap.HashMap Full.Name (Type m)
-    -> Maybe In.Type
-lookupInputType (Full.TypeNamed name) types =
-    case HashMap.lookup name types of
-        Just (ScalarType scalarType) ->
-            Just $ In.NamedScalarType scalarType
-        Just (EnumType enumType) ->
-            Just $ In.NamedEnumType enumType
-        Just (InputObjectType objectType) ->
-            Just $ In.NamedInputObjectType objectType
-        _ -> Nothing
-lookupInputType (Full.TypeList list) types
-    = In.ListType
-    <$> lookupInputType list types
-lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
-    case HashMap.lookup nonNull types of
-        Just (ScalarType scalarType) ->
-            Just $ In.NonNullScalarType scalarType
-        Just (EnumType enumType) ->
-            Just $ In.NonNullEnumType enumType
-        Just (InputObjectType objectType) ->
-            Just $ In.NonNullInputObjectType objectType
-        _ -> Nothing
-lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
-    = In.NonNullListType
-    <$> lookupInputType nonNull types
-
 coerceVariableValues :: Coerce.VariableValue a
     => forall m
     . HashMap Full.Name (Type m)

src/Language/GraphQL/Type/Internal.hs

@@ -10,12 +10,13 @@ module Language.GraphQL.Type.Internal
     , collectReferencedTypes
     , doesFragmentTypeApply
     , instanceOf
+    , lookupInputType
     , lookupTypeCondition
     ) where
 
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@@ -35,7 +36,7 @@ data AbstractType m
     deriving Eq
 
 -- | Traverses the schema and finds all referenced types.
-collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
+collectReferencedTypes :: forall m. Schema m -> HashMap Full.Name (Type m)
 collectReferencedTypes schema =
     let queryTypes = traverseObjectType (query schema) HashMap.empty
         mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
@@ -121,8 +122,8 @@ instanceOf objectType (AbstractUnionType unionType) =
     go unionMemberType acc = acc || objectType == unionMemberType
 
 lookupTypeCondition :: forall m
-    . Name
-    -> HashMap Name (Type m)
+    . Full.Name
+    -> HashMap Full.Name (Type m)
     -> Maybe (CompositeType m)
 lookupTypeCondition type' types' =
     case HashMap.lookup type' types' of
@@ -131,3 +132,32 @@ lookupTypeCondition type' types' =
         Just (InterfaceType interfaceType) ->
             Just $ CompositeInterfaceType interfaceType
         _ -> Nothing
+
+lookupInputType
+    :: Full.Type
+    -> HashMap.HashMap Full.Name (Type m)
+    -> Maybe In.Type
+lookupInputType (Full.TypeNamed name) types =
+    case HashMap.lookup name types of
+        Just (ScalarType scalarType) ->
+            Just $ In.NamedScalarType scalarType
+        Just (EnumType enumType) ->
+            Just $ In.NamedEnumType enumType
+        Just (InputObjectType objectType) ->
+            Just $ In.NamedInputObjectType objectType
+        _ -> Nothing
+lookupInputType (Full.TypeList list) types
+    = In.ListType
+    <$> lookupInputType list types
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
+    case HashMap.lookup nonNull types of
+        Just (ScalarType scalarType) ->
+            Just $ In.NonNullScalarType scalarType
+        Just (EnumType enumType) ->
+            Just $ In.NonNullEnumType enumType
+        Just (InputObjectType objectType) ->
+            Just $ In.NonNullInputObjectType objectType
+        _ -> Nothing
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
+    = In.NonNullListType
+    <$> lookupInputType nonNull types

src/Language/GraphQL/Validate/Rules.hs

@@ -23,9 +23,10 @@ module Language.GraphQL.Validate.Rules
     , uniqueFragmentNamesRule
     , uniqueOperationNamesRule
     , uniqueVariableNamesRule
+    , variablesAreInputTypesRule
     ) where
 
-import Control.Monad (foldM)
+import Control.Monad ((>=>), foldM)
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Reader (ReaderT, asks)
 import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
@@ -67,6 +68,7 @@ specifiedRules =
     , uniqueDirectiveNamesRule
     -- Variables.
     , uniqueVariableNamesRule
+    , variablesAreInputTypesRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
@@ -505,3 +507,29 @@ uniqueVariableNamesRule = VariablesRule
   where
     extract (VariableDefinition variableName _ _ location) =
         (variableName, location)
+
+-- | Variables can only be input types. Objects, unions and interfaces cannot be
+-- used as inputs.
+variablesAreInputTypesRule :: forall m. Rule m
+variablesAreInputTypesRule = VariablesRule
+    $ (traverse check . Seq.fromList) >=> lift
+  where
+    check (VariableDefinition name typeName _ location)
+        = asks types
+        >>= lift
+        . maybe (makeError name typeName location) (const mempty)
+        . lookupInputType typeName
+    makeError name typeName location = pure $ Error
+        { message = concat
+            [ "Variable \"$"
+            , Text.unpack name
+            , "\" cannot be non-input type \""
+            , Text.unpack $ getTypeName typeName
+            , "\"."
+            ]
+        , locations = [location]
+        }
+    getTypeName (TypeNamed name) = name
+    getTypeName (TypeList name) = getTypeName name
+    getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull
+    getTypeName (TypeNonNull (NonNullTypeList nonNull)) = getTypeName nonNull

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.14
+resolver: lts-16.15
 
 packages:
 - .

tests/Language/GraphQL/ValidateSpec.hs

@@ -456,3 +456,18 @@ spec =
                     , locations = [AST.Location 2 39, AST.Location 2 63]
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects non-input types as variables" $
+            let queryString = [r|
+              query takesDogBang($dog: Dog!) {
+                dog {
+                  isHousetrained(atOtherHomes: $dog)
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Variable \"$dog\" cannot be non-input type \"Dog\"."
+                    , locations = [AST.Location 2 34]
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected