Validate all variables are defined

CHANGELOG.md

@@ -11,6 +11,7 @@ and this project adheres to
 - `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
   and  `InlineFragment`. Thus validation rules can be defined more concise.
 - `AST.Document`: `Argument` and `Directive` contain token location.
+- `AST.Document.Argument` contains the `Value` wrapped in the `Node`.
 - `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the
 - same).
 - `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`
@@ -32,7 +33,6 @@ and this project adheres to
   - `ArgumentsRule`
   - `DirectivesRule`
   - `VariablesRule`
-
 - `Validate.Rules`:
   - `fragmentsOnCompositeTypesRule`
   - `fragmentSpreadTargetDefinedRule`
@@ -43,9 +43,12 @@ and this project adheres to
   - `uniqueDirectiveNamesRule`
   - `uniqueVariableNamesRule`
   - `variablesAreInputTypesRule`
+  - `noUndefinedVariablesRule`
+  - `noUndefinedVariablesRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.
+- `AST.Document.Node`.
 
 ### Fixed
 - Collecting existing types from the schema considers subscriptions.

src/Language/GraphQL/AST/Document.hs

@@ -24,6 +24,7 @@ module Language.GraphQL.AST.Document
     , Location(..)
     , Name
     , NamedType
+    , Node(..)
     , NonNullType(..)
     , ObjectField(..)
     , OperationDefinition(..)
@@ -70,6 +71,9 @@ instance Ord Location where
         | thisLine > thatLine = GT
         | otherwise = compare thisColumn thatColumn
 
+-- | Contains some tree node with a location.
+data Node a = Node a Location deriving (Eq, Show)
+
 -- ** Document
 
 -- | GraphQL document.
@@ -190,7 +194,7 @@ data FragmentSpread = FragmentSpread Name [Directive] Location
 -- @
 --
 --  Here "id" is an argument for the field "user" and its value is 4.
-data Argument = Argument Name Value Location deriving (Eq,Show)
+data Argument = Argument Name (Node Value) Location deriving (Eq, Show)
 
 -- ** Fragments
 

src/Language/GraphQL/AST/Encoder.hs

@@ -159,7 +159,7 @@ arguments :: Formatter -> [Argument] -> Lazy.Text
 arguments formatter = parensCommas formatter $ argument formatter
 
 argument :: Formatter -> Argument -> Lazy.Text
-argument formatter (Argument name value' _)
+argument formatter (Argument name (Node value' _) _)
     = Lazy.Text.fromStrict name
     <> colon formatter
     <> value formatter value'

src/Language/GraphQL/AST/Parser.hs

@@ -402,7 +402,7 @@ argument = label "Argument" $ do
     location <- getLocation
     name' <- name
     colon
-    value' <- value
+    value' <- valueNode
     pure $ Argument name' value' location
 
 fragmentSpread :: Parser FragmentSpread
@@ -439,6 +439,12 @@ fragmentName = but (symbol "on") *> name <?> "FragmentName"
 typeCondition :: Parser TypeCondition
 typeCondition = symbol "on" *> name <?> "TypeCondition"
 
+valueNode :: Parser (Node Value)
+valueNode = do
+    location <- getLocation
+    value' <- value
+    pure $ Node value' location
+
 value :: Parser Value
 value = Variable <$> variable
     <|> Float <$> try float

src/Language/GraphQL/Execute/Transform.hs

@@ -274,7 +274,7 @@ field (Full.Field alias name arguments' directives' selections _) = do
     let field' = Field alias name fieldArguments fieldSelections
     pure $ field' <$ fieldDirectives
   where
-    go arguments (Full.Argument name' value' _) =
+    go arguments (Full.Argument name' (Full.Node value' _) _) =
         inputField arguments name' value'
 
 fragmentSpread
@@ -333,7 +333,7 @@ directives = traverse directive
     directive (Full.Directive directiveName directiveArguments _)
         = Definition.Directive directiveName . Type.Arguments
         <$> foldM go HashMap.empty directiveArguments
-    go arguments (Full.Argument name value' _) = do
+    go arguments (Full.Argument name (Full.Node value' _) _) = do
         substitutedValue <- value value'
         return $ HashMap.insert name substitutedValue arguments
 

src/Language/GraphQL/Validate/Rules.hs

@@ -2,9 +2,9 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
-{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
 
 -- | This module contains default rules defined in the GraphQL specification.
@@ -15,6 +15,7 @@ module Language.GraphQL.Validate.Rules
     , fragmentSpreadTypeExistenceRule
     , loneAnonymousOperationRule
     , noFragmentCyclesRule
+    , noUndefinedVariablesRule
     , noUnusedFragmentsRule
     , singleFieldSubscriptionsRule
     , specifiedRules
@@ -28,14 +29,16 @@ module Language.GraphQL.Validate.Rules
 
 import Control.Monad ((>=>), foldM)
 import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Reader (ReaderT, asks)
+import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)
 import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
 import Data.Bifunctor (first)
-import Data.Foldable (find)
+import Data.Foldable (find, toList)
 import qualified Data.HashMap.Strict as HashMap
 import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import Data.List (groupBy, sortBy, sortOn)
+import Data.Maybe (mapMaybe)
 import Data.Ord (comparing)
 import Data.Sequence (Seq(..))
 import qualified Data.Sequence as Seq
@@ -46,6 +49,9 @@ import Language.GraphQL.Type.Internal
 import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Validate.Validation
 
+-- Local help type that contains a hash set to track visited fragments.
+type ValidationState m a = StateT (HashSet Name) (ReaderT (Validation m) Seq) a
+
 -- | Default rules given in the specification.
 specifiedRules :: forall m. [Rule m]
 specifiedRules =
@@ -69,6 +75,7 @@ specifiedRules =
     -- Variables.
     , uniqueVariableNamesRule
     , variablesAreInputTypesRule
+    , noUndefinedVariablesRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
@@ -133,8 +140,10 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
             collectFromFragment typeCondition selections accumulator
         | otherwise = HashSet.union accumulator
             <$> collectFields selections
-    skip (Directive "skip" [Argument "if" (Boolean True) _] _) = True
+    skip (Directive "skip" [Argument "if" (Node argumentValue _) _] _) =
-    skip (Directive "include" [Argument "if" (Boolean False) _] _) = True
+        Boolean True == argumentValue
+    skip (Directive "include" [Argument "if" (Node argumentValue _) _] _) =
+        Boolean False == argumentValue
     skip _ = False
     findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
         | DefinitionFragment fragmentDefinition <- executableDefinition =
@@ -358,43 +367,57 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
 
 -- | Defined fragments must be used within a document.
 noUnusedFragmentsRule :: forall m. Rule m
-noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment ->
+noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
-    asks ast >>= findSpreadByName fragment
+    let FragmentDefinition fragmentName _ _ _ location = fragment
+     in mapReaderT (checkFragmentName fragmentName location)
+        $ asks ast
+        >>= flip evalStateT HashSet.empty
+        . filterSelections evaluateSelection
+        . foldMap definitionSelections
   where
-    findSpreadByName (FragmentDefinition fragName _ _ _ location) definitions
+    checkFragmentName fragmentName location elements
-        | foldr (go fragName) False definitions = lift mempty
+        | fragmentName `elem` elements = mempty
-        | otherwise = pure $ Error
+        | otherwise = pure $ makeError fragmentName location
-            { message = errorMessage fragName
+    makeError fragName location = Error
-            , locations = [location]
+        { message = errorMessage fragName
-            }
+        , locations = [location]
+        }
     errorMessage fragName = concat
         [ "Fragment \""
         , Text.unpack fragName
         , "\" is never used."
         ]
-    go fragName (viewOperation -> Just operation) accumulator
+    evaluateSelection selection
-        | SelectionSet selections _ <- operation =
-            evaluateSelections fragName accumulator selections
-        | OperationDefinition _ _ _ _ selections _ <- operation =
-            evaluateSelections fragName accumulator selections
-    go fragName (viewFragment -> Just fragment) accumulator
-        | FragmentDefinition _ _ _ selections _ <- fragment =
-            evaluateSelections fragName accumulator selections
-    go _ _ _ = False
-    evaluateSelection fragName selection accumulator
         | FragmentSpreadSelection spreadSelection <- selection
-        , FragmentSpread spreadName _ _ <- spreadSelection
+        , FragmentSpread spreadName _ _ <- spreadSelection =
-        , spreadName == fragName = True
+            lift $ pure spreadName
+    evaluateSelection _ = lift $ lift mempty
+
+definitionSelections :: Definition -> SelectionSetOpt
+definitionSelections (viewOperation -> Just operation)
+    | OperationDefinition _ _ _ _ selections _ <- operation = toList selections
+    | SelectionSet selections _ <- operation = toList selections
+definitionSelections (viewFragment -> Just fragment)
+    | FragmentDefinition _ _ _ selections _ <- fragment = toList selections
+definitionSelections _ = []
+
+filterSelections :: Foldable t
+    => forall a m
+    . (Selection -> ValidationState m a)
+    -> t Selection
+    -> ValidationState m a
+filterSelections applyFilter selections
+    = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections)
+    >>= applyFilter
+  where
+    evaluateSelection selection accumulator
+        | FragmentSpreadSelection{} <- selection = selection : accumulator
         | FieldSelection fieldSelection <- selection
-        , Field _ _ _ _ selections _ <- fieldSelection =
+        , Field _ _ _ _ subselections _ <- fieldSelection =
-            evaluateSelections fragName accumulator selections
+            selection : foldr evaluateSelection accumulator subselections
         | InlineFragmentSelection inlineSelection <- selection
-        , InlineFragment _ _ selections _ <- inlineSelection =
+        , InlineFragment _ _ subselections _ <- inlineSelection =
-            evaluateSelections fragName accumulator selections
+            selection : foldr evaluateSelection accumulator subselections
-        | otherwise = accumulator || False
-    evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool
-    evaluateSelections fragName accumulator selections =
-        foldr (evaluateSelection fragName) accumulator selections
 
 -- | The graph of fragment spreads must not form any cycles including spreading
 -- itself. Otherwise an operation could infinitely spread or infinitely execute
@@ -419,8 +442,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
             _ -> lift mempty
   where
     collectFields :: Traversable t
-        => forall m
+        => t Selection
-        . t Selection
         -> StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
     collectFields selectionSet = foldM forEach HashMap.empty selectionSet
     forEach accumulator = \case
@@ -434,7 +456,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
         modify $ first (+ 1)
         lastIndex <- gets fst
         let newAccumulator = HashMap.insert fragmentName lastIndex accumulator
-        let inVisitetFragment =HashMap.member fragmentName accumulator
+        let inVisitetFragment = HashMap.member fragmentName accumulator
         if fragmentName == firstFragmentName || inVisitetFragment
             then pure newAccumulator
             else collectFromSpread fragmentName newAccumulator
@@ -533,3 +555,69 @@ variablesAreInputTypesRule = VariablesRule
     getTypeName (TypeList name) = getTypeName name
     getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull
     getTypeName (TypeNonNull (NonNullTypeList nonNull)) = getTypeName nonNull
+
+-- | Variables are scoped on a per‐operation basis. That means that any variable
+-- used within the context of an operation must be defined at the top level of
+-- that operation.
+noUndefinedVariablesRule :: forall m. Rule m
+noUndefinedVariablesRule = OperationDefinitionRule $ \case
+    SelectionSet _ _ -> lift mempty
+    OperationDefinition _ operationName variables _ selections _ ->
+        let variableNames = HashMap.fromList $ getVariableName <$> variables
+         in mapReaderT (readerMapper operationName variableNames)
+            $ flip evalStateT HashSet.empty
+            $ filterSelections'
+            $ toList selections
+  where
+    readerMapper operationName variableNames' = Seq.fromList
+        . fmap (makeError operationName)
+        . HashMap.toList
+        . flip HashMap.difference variableNames'
+        . HashMap.fromListWith (++)
+        . toList
+    getVariableName (VariableDefinition variableName _ _ _) = (variableName, [])
+    filterSelections' :: Foldable t
+        => t Selection
+        -> ValidationState m (Name, [Location])
+    filterSelections' = filterSelections variableFilter
+    variableFilter :: Selection -> ValidationState m (Name, [Location])
+    variableFilter (InlineFragmentSelection inline)
+        | InlineFragment _ directives _ _ <- inline =
+            lift $ lift $ mapDirectives directives
+    variableFilter (FieldSelection fieldSelection)
+        | Field _ _ arguments directives _ _ <- fieldSelection =
+            lift $ lift $ mapArguments arguments <> mapDirectives directives
+    variableFilter (FragmentSpreadSelection spread)
+        | FragmentSpread fragmentName _ _ <- spread = do
+            definitions <- lift $ asks ast
+            visited <- gets (HashSet.member fragmentName)
+            modify (HashSet.insert fragmentName)
+            case find (isSpreadTarget fragmentName) definitions of
+                Just (viewFragment -> Just fragmentDefinition)
+                    | not visited -> diveIntoSpread fragmentDefinition
+                _ -> lift $ lift mempty
+    diveIntoSpread (FragmentDefinition _ _ directives selections _)
+        = filterSelections' selections
+        >>= lift . mapReaderT (<> mapDirectives directives) . pure
+    findDirectiveVariables (Directive _ arguments _) = mapArguments arguments
+    mapArguments = Seq.fromList . mapMaybe findArgumentVariables
+    mapDirectives = foldMap findDirectiveVariables
+    findArgumentVariables (Argument _ (Node (Variable value) location) _) =
+        Just (value, [location])
+    findArgumentVariables _ = Nothing
+    makeError operationName (variableName, locations') = Error
+        { message = errorMessage operationName variableName
+        , locations = locations'
+        }
+    errorMessage Nothing variableName = concat
+        [ "Variable \"$"
+        , Text.unpack variableName
+        , "\" is not defined."
+        ]
+    errorMessage (Just operationName) variableName = concat
+        [ "Variable \"$"
+        , Text.unpack variableName
+        , "\" is not defined by operation \""
+        , Text.unpack operationName
+        , "\"."
+        ]

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -122,7 +122,8 @@ spec = do
     describe "definition" $
         it "indents block strings in arguments" $
             let location = Location 0 0
-                arguments = [Argument "message" (String "line1\nline2") location]
+                argumentValue = Node (String "line1\nline2") location
+                arguments = [Argument "message" argumentValue location]
                 field = Field Nothing "field" arguments [] [] location
                 operation = DefinitionOperation
                     $ SelectionSet (pure $ FieldSelection field) location

tests/Language/GraphQL/ValidateSpec.hs

@@ -471,3 +471,24 @@ spec =
                     , locations = [AST.Location 2 34]
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects undefined variables" $
+            let queryString = [r|
+              query variableIsNotDefinedUsedInSingleFragment {
+                dog {
+                  ...isHousetrainedFragment
+                }
+              }
+
+              fragment isHousetrainedFragment on Dog {
+                isHousetrained(atOtherHomes: $atOtherHomes)
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Variable \"$atOtherHomes\" is not defined by \
+                        \operation \
+                        \\"variableIsNotDefinedUsedInSingleFragment\"."
+                    , locations = [AST.Location 9 46]
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected