Validate fragment spread type existence

CHANGELOG.md

@@ -8,7 +8,7 @@ and this project adheres to
 
 ## [Unreleased]
 ### Changed
-- Added location information to `AST.Document.Selection.FragmentSpread`.
+- Added location information to `AST.Document.Selection`.
 
 ### Added
 - `Validate.Validation.Rule`: `SelectionRule` constructor.

src/Language/GraphQL/AST/Document.hs

@@ -162,9 +162,9 @@ type SelectionSetOpt = [Selection]
 -- }
 -- @
 data Selection
-    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
+    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
     | FragmentSpread Name [Directive] Location
-    | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
+    | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet Location
     deriving (Eq, Show)
 
 -- ** Arguments

src/Language/GraphQL/AST/Encoder.hs

@@ -126,9 +126,9 @@ indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
 selection :: Formatter -> Selection -> Lazy.Text
 selection formatter = Lazy.Text.append indent' . encodeSelection
   where
-    encodeSelection (Field alias name args directives' selections) =
+    encodeSelection (Field alias name args directives' selections _) =
         field incrementIndent alias name args directives' selections
-    encodeSelection (InlineFragment typeCondition directives' selections) =
+    encodeSelection (InlineFragment typeCondition directives' selections _) =
         inlineFragment incrementIndent typeCondition directives' selections
     encodeSelection (FragmentSpread name directives' _) =
         fragmentSpread incrementIndent name directives'

src/Language/GraphQL/AST/Parser.hs

@@ -382,13 +382,14 @@ selection = field
     <?> "Selection"
 
 field :: Parser Selection
-field = Field
+field = label "Field" $ do
-    <$> optional alias
+    location <- getLocation
-    <*> name
+    alias' <- optional alias
-    <*> arguments
+    name' <- name
-    <*> directives
+    arguments' <- arguments
-    <*> selectionSetOpt
+    directives' <- directives
-    <?> "Field"
+    selectionSetOpt' <- selectionSetOpt
+    pure $ Field alias' name' arguments' directives' selectionSetOpt' location
 
 alias :: Parser Alias
 alias = try (name <* colon) <?> "Alias"
@@ -408,12 +409,13 @@ fragmentSpread = label "FragmentSpread" $ do
     pure $ FragmentSpread fragmentName' directives' location
 
 inlineFragment :: Parser Selection
-inlineFragment = InlineFragment
+inlineFragment = label "InlineFragment" $ do
-    <$ spread
+    location <- getLocation
-    <*> optional typeCondition
+    _ <- spread
-    <*> directives
+    typeCondition' <- optional typeCondition
-    <*> selectionSet
+    directives' <- directives
-    <?> "InlineFragment"
+    selectionSet' <- selectionSet
+    pure $ InlineFragment typeCondition' directives' selectionSet' location
 
 fragmentDefinition :: Parser FragmentDefinition
 fragmentDefinition =  label "FragmentDefinition" $ do

src/Language/GraphQL/Execute/Transform.hs

@@ -288,7 +288,7 @@ operation operationDefinition replacement
 selection
     :: Full.Selection
     ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-selection (Full.Field alias name arguments' directives' selections) =
+selection (Full.Field alias name arguments' directives' selections _) =
     maybe (Left mempty) (Right . SelectionField) <$> do
         fieldArguments <- foldM go HashMap.empty arguments'
         fieldSelections <- appendSelection selections
@@ -314,7 +314,7 @@ selection (Full.FragmentSpread name directives' _) =
                         Just fragment -> lift $ pure $ fragment <$ spreadDirectives
                         _ -> lift $ pure  Nothing
                 | otherwise -> lift $ pure  Nothing
-selection (Full.InlineFragment type' directives' selections) = do
+selection (Full.InlineFragment type' directives' selections _) = do
     fragmentDirectives <- Definition.selection <$> directives directives'
     case fragmentDirectives of
         Nothing -> pure $ Left mempty

src/Language/GraphQL/Validate.hs

@@ -76,14 +76,17 @@ operationDefinition operation =
     getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
 
 selection :: forall m. Selection -> ValidateT m
-selection selection'@FragmentSpread{} =
+selection selection'
+    | FragmentSpread{} <- selection' =
         asks rules >>= foldM ruleFilter Seq.empty
+    | Field _ _ _ _ selectionSet _ <- selection' =
+        visitChildSelections ruleFilter selectionSet
+    | InlineFragment _ _ selectionSet _ <- selection' =
+        visitChildSelections ruleFilter selectionSet
   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

src/Language/GraphQL/Validate/Rules.hs

@@ -89,7 +89,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
     errorMessage =
         "Anonymous Subscription must select only one top level field."
     collectFields selectionSet = foldM forEach HashSet.empty selectionSet
-    forEach accumulator (Field alias name _ directives _)
+    forEach accumulator (Field alias name _ directives _ _)
         | any skip directives = pure accumulator
         | Just aliasedName <- alias = pure
             $ HashSet.insert aliasedName accumulator
@@ -101,7 +101,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
             if inVisitetFragments
                then pure accumulator
                else collectFromSpread fragmentName accumulator
-    forEach accumulator (InlineFragment typeCondition' directives selectionSet)
+    forEach accumulator (InlineFragment typeCondition' directives selectionSet _)
         | any skip directives = pure accumulator
         | Just typeCondition <- typeCondition' =
             collectFromFragment typeCondition selectionSet accumulator
@@ -269,7 +269,16 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
         types' <- asks types
         case HashMap.lookup typeCondition types' of
             Nothing -> pure $ Error
-                { message = error' fragmentName typeCondition
+                { message = spreadError fragmentName typeCondition
+                , locations = [location]
+                , path = []
+                }
+            Just _ -> lift Nothing
+    InlineFragment (Just typeCondition) _ _ location -> do
+        types' <- asks types
+        case HashMap.lookup typeCondition types' of
+            Nothing -> pure $ Error
+                { message = inlineError typeCondition
                 , locations = [location]
                 , path = []
                 }
@@ -280,10 +289,15 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
         let FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
          in pure typeCondition
     extractTypeCondition _ = lift Nothing
-    error' fragmentName typeCondition = concat
+    spreadError fragmentName typeCondition = concat
         [ "Fragment \""
         , Text.unpack fragmentName
         , "\" is specified on type \""
         , Text.unpack typeCondition
         , "\" which doesn't exist in the schema."
         ]
+    inlineError typeCondition = concat
+        [ "Inline fragment is specified on type \""
+        , Text.unpack typeCondition
+        , "\" which doesn't exist in the schema."
+        ]

tests/Language/GraphQL/AST/EncoderSpec.hs

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

tests/Language/GraphQL/ValidateSpec.hs

@@ -300,7 +300,7 @@ spec =
                     }
              in validate queryString `shouldBe` Seq.singleton expected
 
-        it "rejects the fragment spread without a target" $
+        it "rejects fragment spreads without an unknown target type" $
             let queryString = [r|
               {
                 dog {
@@ -319,3 +319,20 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects inline fragments without a target" $
+            let queryString = [r|
+              {
+                ... on NotInSchema {
+                  name
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Inline fragment is specified on type \"NotInSchema\" \
+                        \which doesn't exist in the schema."
+                    , locations = [AST.Location 3 17]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected