Validate fragment spread target existence

CHANGELOG.md

@@ -6,28 +6,36 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
+## [Unreleased]
+### Changed
+- Added location information to `AST.Document.Selection.FragmentSpread`.
+
+### Added
+- `Validate.Validation.Rule`: `SelectionRule` constructor.
+- `Validate.Rules`: `fragmentSpreadTargetDefinedRule`.
+
 ## [0.10.0.0] - 2020-08-29
-## Changed
+### Changed
 - `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.
 - The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was
   moved to `OperationDefinition` and `FragmentDefinition` since these are the
   actual elements that have a location in the document.
 - `Validate.Rules` get the whole validation context (AST and schema).
 
-## Added
+### Added
 - `Validate.Validation` contains data structures and functions used by the
   validator and concretet rules.
 - `Validate.Rules`: operation validation rules.
 
 ## [0.9.0.0] - 2020-07-24
-## Fixed
+### Fixed
 - Location of a parse error is returned in a singleton array with key
   `locations`.
 - Parsing comments in the front of definitions.
 - Some missing labels were added to the parsers, some labels were fixed to
   refer to the AST nodes being parsed. 
 
-## Added
+### Added
 - `AST` reexports `AST.Parser`.
 - `AST.Document.Location` is a token location as a line and column pair.
 - `Execute` reexports `Execute.Coerce`.
@@ -43,7 +51,7 @@ and this project adheres to
 - `Test.Hspec.GraphQL` contains some test helpers.
 - `Validate` contains the validator and standard rules.
 
-## Changed
+### Changed
 - `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
   have value resolvers, root subscription type resolvers need an additional
   resolver that creates an event stream. `Resolver` represents these differences
@@ -67,7 +75,7 @@ and this project adheres to
 - The constraint of the base monad was changed to `MonadCatch` (and it implies
   `MonadThrow`).
 
-## Removed
+### Removed
 - `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
   represents possible resolver configurations.
 - `Execute.executeWithName`. `Execute.execute` takes the operation name and
@@ -334,6 +342,7 @@ and this project adheres to
 ### Added
 - Data types for the GraphQL language.
 
+[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.10.0.0...HEAD
 [0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0
 [0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0
 [0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0

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)
 

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

src/Language/GraphQL/AST/Parser.hs

@@ -400,11 +400,12 @@ argument :: Parser Argument
 argument = Argument <$> name <* colon <*> value <?> "Argument"
 
 fragmentSpread :: Parser Selection
-fragmentSpread = FragmentSpread
+fragmentSpread = label "FragmentSpread" $ do
-    <$ spread
+    location <- getLocation
-    <*> fragmentName
+    _ <- spread
-    <*> directives
+    fragmentName' <- fragmentName
-    <?> "FragmentSpread"
+    directives' <- directives
+    pure $ FragmentSpread fragmentName' directives' location
 
 inlineFragment :: Parser Selection
 inlineFragment = InlineFragment

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

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,15 +66,41 @@ 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
+
+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 fragment@(FragmentDefinition _ _ _ selectionSet _) =
-    asks rules >>= foldM ruleFilter Seq.empty
+    visitChildSelections ruleFilter selectionSet
   where
     ruleFilter accumulator (FragmentDefinitionRule rule) =
         mapReaderT (runRule accumulator) $ rule fragment

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
+        | Just fragmentDefinition <- viewFragment definition
-        , DefinitionFragment fragmentDefinition <- executableDefinition
         , 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

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

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.11
+resolver: lts-16.12
 
 packages:
 - .
@@ -6,4 +6,4 @@ packages:
 extra-deps: []
 flags: {}
 
-pvp-bounds: both
+pvp-bounds: lower

tests/Language/GraphQL/ValidateSpec.hs

@@ -281,3 +281,19 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects the fragment spread without a target" $
+            let queryString = [r|
+              {
+                dog {
+                  ...undefinedFragment
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment target \"undefinedFragment\" is undefined."
+                    , locations = [AST.Location 4 19]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected