diff options
| -rw-r--r-- | CHANGELOG.md | 2 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Document.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 28 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate.hs | 11 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 22 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/EncoderSpec.hs | 2 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ValidateSpec.hs | 19 |
9 files changed, 66 insertions, 30 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index bb3dbcc..65c86f4 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 3b94e55..f780a9d 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index ec28b86..7428365 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/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' diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index e97f306..af82a9e 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -382,13 +382,14 @@ selection = field <?> "Selection" field :: Parser Selection -field = Field - <$> optional alias - <*> name - <*> arguments - <*> directives - <*> selectionSetOpt - <?> "Field" +field = label "Field" $ do + location <- getLocation + alias' <- optional alias + name' <- name + arguments' <- arguments + directives' <- directives + 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 - <$ spread - <*> optional typeCondition - <*> directives - <*> selectionSet - <?> "InlineFragment" +inlineFragment = label "InlineFragment" $ do + location <- getLocation + _ <- spread + typeCondition' <- optional typeCondition + directives' <- directives + selectionSet' <- selectionSet + pure $ InlineFragment typeCondition' directives' selectionSet' location fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = label "FragmentDefinition" $ do diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index deeb5b9..b438bdf 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/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 diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 6ff1f57..7a25ce4 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -76,14 +76,17 @@ operationDefinition operation = getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet selection :: forall m. Selection -> ValidateT m -selection selection'@FragmentSpread{} = - asks rules >>= foldM ruleFilter Seq.empty +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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index ec51bbd..78d1901 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/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." + ] diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index 5fa3706..85add18 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/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 diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index eef5d38..990555e 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/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 |