Validate fragment spread target existence

7 files changed, 76 insertions, 15 deletions

diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 72d39bb..3b94e55 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -163,7 +163,7 @@ type SelectionSetOpt = [Selection]
 -- @
 data Selection
     = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
-    | FragmentSpread Name [Directive]
+    | FragmentSpread Name [Directive] Location
     | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
     deriving (Eq, Show)
 
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index ba89d36..ec28b86 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -130,7 +130,7 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
         field incrementIndent alias name args directives' selections
     encodeSelection (InlineFragment typeCondition directives' selections) =
         inlineFragment incrementIndent typeCondition directives' selections
-    encodeSelection (FragmentSpread name directives') =
+    encodeSelection (FragmentSpread name directives' _) =
         fragmentSpread incrementIndent name directives'
     incrementIndent
         | Pretty indentation <- formatter = Pretty $ indentation + 1
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 7bc51cb..e97f306 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -400,11 +400,12 @@ argument :: Parser Argument
 argument = Argument <$> name <* colon <*> value <?> "Argument"
 
 fragmentSpread :: Parser Selection
-fragmentSpread = FragmentSpread
-    <$ spread
-    <*> fragmentName
-    <*> directives
-    <?> "FragmentSpread"
+fragmentSpread = label "FragmentSpread" $ do
+    location <- getLocation
+    _ <- spread
+    fragmentName' <- fragmentName
+    directives' <- directives
+    pure $ FragmentSpread fragmentName' directives' location
 
 inlineFragment :: Parser Selection
 inlineFragment = InlineFragment
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 9c7ad0a..deeb5b9 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -299,7 +299,7 @@ selection (Full.Field alias name arguments' directives' selections) =
     go arguments (Full.Argument name' value') =
         inputField arguments name' value'
 
-selection (Full.FragmentSpread name directives') =
+selection (Full.FragmentSpread name directives' _) =
     maybe (Left mempty) (Right . SelectionFragment) <$> do
         spreadDirectives <- Definition.selection <$> directives directives'
         fragments' <- gets fragments
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 53dc6f9..6ff1f57 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -15,7 +15,7 @@ module Language.GraphQL.Validate
 
 import Control.Monad (foldM)
 import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
-import Data.Foldable (foldrM)
+import Data.Foldable (fold, foldrM)
 import Data.Sequence (Seq(..), (><), (|>))
 import qualified Data.Sequence as Seq
 import Language.GraphQL.AST.Document
@@ -66,16 +66,42 @@ executableDefinition (DefinitionFragment definition') =
 
 operationDefinition :: forall m. OperationDefinition -> ValidateT m
 operationDefinition operation =
-    asks rules >>= foldM ruleFilter Seq.empty
+    let selectionSet = getSelectionSet operation
+     in visitChildSelections ruleFilter selectionSet
   where
     ruleFilter accumulator (OperationDefinitionRule rule) =
         mapReaderT (runRule accumulator) $ rule operation
     ruleFilter accumulator _ = pure accumulator
+    getSelectionSet (SelectionSet selectionSet _) = selectionSet
+    getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
 
-fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
-fragmentDefinition fragment =
+selection :: forall m. Selection -> ValidateT m
+selection selection'@FragmentSpread{} =
     asks rules >>= foldM ruleFilter Seq.empty
   where
+    ruleFilter accumulator (SelectionRule rule) =
+        mapReaderT (runRule accumulator) $ rule selection'
+    ruleFilter accumulator _ = pure accumulator
+selection (Field _ _ _ _ selectionSet) = traverseSelectionSet selectionSet
+selection (InlineFragment _ _ selectionSet) = traverseSelectionSet selectionSet
+
+traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m
+traverseSelectionSet = fmap fold . traverse selection
+
+visitChildSelections :: Traversable t
+    => (Seq Error -> Rule m -> ValidateT m)
+    -> t Selection
+    -> ValidateT m
+visitChildSelections ruleFilter selectionSet = do
+    rules' <- asks rules
+    applied <- foldM ruleFilter Seq.empty rules'
+    children <- traverseSelectionSet selectionSet
+    pure $ children >< applied
+
+fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
+fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) =
+    visitChildSelections ruleFilter selectionSet
+  where
     ruleFilter accumulator (FragmentDefinitionRule rule) =
         mapReaderT (runRule accumulator) $ rule fragment
     ruleFilter accumulator _ = pure accumulator
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 690631e..c531753 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -21,6 +21,7 @@ import Control.Monad (foldM)
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Reader (asks)
 import Control.Monad.Trans.State (evalStateT, gets, modify)
+import Data.Foldable (find)
 import qualified Data.HashSet as HashSet
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
@@ -36,6 +37,7 @@ specifiedRules =
     , loneAnonymousOperationRule
     , uniqueOperationNamesRule
     , uniqueFragmentNamesRule
+    , fragmentSpreadTargetDefinedRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
@@ -84,7 +86,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
         | Just aliasedName <- alias = pure
             $ HashSet.insert aliasedName accumulator
         | otherwise = pure $ HashSet.insert name accumulator
-    forEach accumulator (FragmentSpread fragmentName directives)
+    forEach accumulator (FragmentSpread fragmentName directives _)
         | any skip directives = pure accumulator
         | otherwise = do
             inVisitetFragments <- gets $ HashSet.member fragmentName
@@ -192,6 +194,13 @@ viewOperation definition
         Just operationDefinition
 viewOperation _ = Nothing
 
+viewFragment :: Definition -> Maybe FragmentDefinition
+viewFragment definition
+    | ExecutableDefinition executableDefinition <- definition
+    , DefinitionFragment fragmentDefinition <- executableDefinition =
+        Just fragmentDefinition
+viewFragment _ = Nothing
+
 -- | Fragment definitions are referenced in fragment spreads by name. To avoid
 -- ambiguity, each fragment’s name must be unique within a document.
 --
@@ -208,8 +217,32 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
         , "\"."
         ]
     filterByName thisName definition accumulator
-        | ExecutableDefinition executableDefinition <- definition
-        , DefinitionFragment fragmentDefinition <- executableDefinition
+        | Just fragmentDefinition <- viewFragment definition
         , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
         , thisName == thatName = thatLocation : accumulator
         | otherwise = accumulator
+
+-- | Named fragment spreads must refer to fragments defined within the document.
+-- It is a validation error if the target of a spread is not defined.
+fragmentSpreadTargetDefinedRule :: forall m. Rule m
+fragmentSpreadTargetDefinedRule = SelectionRule $ \case
+    FragmentSpread fragmentName _ location -> do
+        ast' <- asks ast
+        case find (findTarget fragmentName) ast' of
+            Nothing -> pure $ Error
+                { message = error' fragmentName
+                , locations = [location]
+                , path = []
+                }
+            Just _ -> lift Nothing
+    _ -> lift Nothing
+  where
+    error' fragmentName = concat
+        [ "Fragment target \""
+        , Text.unpack fragmentName
+        , "\" is undefined."
+        ]
+    findTarget thisName (viewFragment -> Just fragmentDefinition)
+        | FragmentDefinition thatName _ _ _ _ <- fragmentDefinition
+        , thisName == thatName = True
+    findTarget _ _ = False
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index 03bbf33..21640bc 100644
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@@ -49,6 +49,7 @@ data Rule m
     = DefinitionRule (Definition -> RuleT m)
     | OperationDefinitionRule (OperationDefinition -> RuleT m)
     | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
+    | SelectionRule (Selection -> RuleT m)
 
 -- | Monad transformer used by the rules.
 type RuleT m = ReaderT (Validation m) Maybe Error