Validate fragments on composite types

2020-09-07 22:01:49 +02:00 · 2020-09-07 22:01:49 +02:00 · f6ff0ab9c7
commit f6ff0ab9c7
parent d327d9d1ce
10 changed files with 212 additions and 103 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -8,13 +8,18 @@ and this project adheres to

 ## [Unreleased]
 ### Changed
- Added location information to `AST.Document.Selection`.
+- `AST.Document.Selection` wraps additional new types: `FragmentSpread`
+  and  `InlineFragment`. Thus validation rules can be more concise.

 ### Added
- `Validate.Validation.Rule`: `SelectionRule` constructor.
+- `Validate.Validation.Rule`: `SelectionRule`, `FragmentRule` and
+  `FragmentSpreadRule` constructors.
 - `Validate.Rules`:
+  - `fragmentsOnCompositeTypesRule`
  - `fragmentSpreadTargetDefinedRule`
  - `fragmentSpreadTypeExistenceRule`
+- `AST.Document.FragmentSpread`.
+- `AST.Document.InlineFragment`.

 ### Fixed
 - Collecting existing types from the schema considers subscriptions.
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@ -17,7 +17,9 @@ module Language.GraphQL.AST.Document
    , ExecutableDefinition(..)
    , FieldDefinition(..)
    , FragmentDefinition(..)
+    , FragmentSpread(..)
    , ImplementsInterfaces(..)
+    , InlineFragment(..)
    , InputValueDefinition(..)
    , Location(..)
    , Name
@ -132,7 +134,28 @@ type SelectionSetOpt = [Selection]
 --   }
 -- }
 -- @
+data Selection
+    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
+    | FragmentSpreadSelection FragmentSpread
+    | InlineFragmentSelection InlineFragment
+    deriving (Eq, Show)
+
+-- Inline fragments don't have any name and the type condition ("on UserType")
+-- is optional.
 --
+-- @
+-- {
+--   user {
+--     ... on UserType {
+--       id
+--       name
+--     }
+-- }
+-- @
+data InlineFragment = InlineFragment
+    (Maybe TypeCondition) [Directive] SelectionSet Location
+    deriving (Eq, Show)
+
 -- A fragment spread refers to a fragment defined outside the operation and is
 -- expanded at the execution time.
 --
@ -148,23 +171,7 @@ type SelectionSetOpt = [Selection]
 --   name
 -- }
 -- @
--
-- Inline fragments are similar but they don't have any name and the type
-- condition ("on UserType") is optional.
--
-- @
-- {
--   user {
--     ... on UserType {
--       id
--       name
--     }
-- }
-- @
-data Selection
-    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
-    | FragmentSpread Name [Directive] Location
-    | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet Location
+data FragmentSpread = FragmentSpread Name [Directive] Location
    deriving (Eq, Show)

 -- ** Arguments
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@ -128,10 +128,10 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
  where
    encodeSelection (Field alias name args directives' selections _) =
        field incrementIndent alias name args directives' selections
-    encodeSelection (InlineFragment typeCondition directives' selections _) =
-        inlineFragment incrementIndent typeCondition directives' selections
-    encodeSelection (FragmentSpread name directives' _) =
-        fragmentSpread incrementIndent name directives'
+    encodeSelection (InlineFragmentSelection fragmentSelection) =
+        inlineFragment incrementIndent fragmentSelection
+    encodeSelection (FragmentSpreadSelection fragmentSelection) =
+        fragmentSpread incrementIndent fragmentSelection
    incrementIndent
        | Pretty indentation <- formatter = Pretty $ indentation + 1
        | otherwise = Minified
@ -172,22 +172,18 @@ argument formatter (Argument name value')

 -- * Fragments

-fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
-fragmentSpread formatter name directives'
+fragmentSpread :: Formatter -> FragmentSpread -> Lazy.Text
+fragmentSpread formatter (FragmentSpread name directives' _)
    = "..." <> Lazy.Text.fromStrict name
    <> optempty (directives formatter) directives'

-inlineFragment ::
-    Formatter ->
-    Maybe TypeCondition ->
-    [Directive] ->
-    SelectionSet ->
-    Lazy.Text
-inlineFragment formatter tc dirs sels = "... on "
-    <> Lazy.Text.fromStrict (fold tc)
-    <> directives formatter dirs
+inlineFragment :: Formatter -> InlineFragment -> Lazy.Text
+inlineFragment formatter (InlineFragment typeCondition directives' selections _)
+    = "... on "
+    <> Lazy.Text.fromStrict (fold typeCondition)
+    <> directives formatter directives'
    <> eitherFormat formatter " " mempty
-    <> selectionSet formatter sels
+    <> selectionSet formatter selections

 fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
 fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@ -377,8 +377,8 @@ selectionSetOpt = listOptIn braces selection <?> "SelectionSet"

 selection :: Parser Selection
 selection = field
-    <|> try fragmentSpread
-    <|> inlineFragment
+    <|> FragmentSpreadSelection <$> try fragmentSpread
+    <|> InlineFragmentSelection <$> inlineFragment
    <?> "Selection"

 field :: Parser Selection
@ -400,7 +400,7 @@ arguments = listOptIn parens argument <?> "Arguments"
 argument :: Parser Argument
 argument = Argument <$> name <* colon <*> value <?> "Argument"

-fragmentSpread :: Parser Selection
+fragmentSpread :: Parser FragmentSpread
 fragmentSpread = label "FragmentSpread" $ do
    location <- getLocation
    _ <- spread
@ -408,7 +408,7 @@ fragmentSpread = label "FragmentSpread" $ do
    directives' <- directives
    pure $ FragmentSpread fragmentName' directives' location

-inlineFragment :: Parser Selection
+inlineFragment :: Parser InlineFragment
 inlineFragment = label "InlineFragment" $ do
    location <- getLocation
    _ <- spread
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@ -298,8 +298,15 @@ selection (Full.Field alias name arguments' directives' selections _) =
  where
    go arguments (Full.Argument name' value') =
        inputField arguments name' value'
+selection (Full.FragmentSpreadSelection fragmentSelection) =
+    fragmentSpread fragmentSelection
+selection (Full.InlineFragmentSelection fragmentSelection) =
+    inlineFragment fragmentSelection

-selection (Full.FragmentSpread name directives' _) =
+fragmentSpread
+    :: Full.FragmentSpread
+    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
+fragmentSpread (Full.FragmentSpread name directives' _) =
    maybe (Left mempty) (Right . SelectionFragment) <$> do
        spreadDirectives <- Definition.selection <$> directives directives'
        fragments' <- gets fragments
@ -314,7 +321,11 @@ 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
+
+inlineFragment
+    :: Full.InlineFragment
+    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
+inlineFragment (Full.InlineFragment type' directives' selections _) = do
    fragmentDirectives <- Definition.selection <$> directives directives'
    case fragmentDirectives of
        Nothing -> pure $ Left mempty
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@ -3,7 +3,6 @@
   obtain one at https://mozilla.org/MPL/2.0/. -}

 {-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE LambdaCase #-}

 -- | GraphQL validator.
 module Language.GraphQL.Validate
@ -41,18 +40,15 @@ document schema' rules' document' =
    go definition' accumulator = (accumulator ><) <$> definition definition'

 definition :: forall m. Definition -> ValidateT m
-definition = \case
-    definition'@(ExecutableDefinition executableDefinition') -> do
-        applied <- applyRules definition'
-        children <- executableDefinition executableDefinition'
-        pure $ children >< applied
-    definition' -> applyRules definition'
+definition definition'
+    | ExecutableDefinition executableDefinition' <- definition'
+        = visitChildSelections ruleFilter
+        $ executableDefinition executableDefinition'
+    | otherwise = asks rules >>= foldM ruleFilter Seq.empty
  where
-    applyRules definition' =
-        asks rules >>= foldM (ruleFilter definition') Seq.empty
-    ruleFilter definition' accumulator (DefinitionRule rule) =
+    ruleFilter accumulator (DefinitionRule rule) =
        mapReaderT (runRule accumulator) $ rule definition'
-    ruleFilter _ accumulator _ = pure accumulator
+    ruleFilter accumulator _ = pure accumulator

 runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
 runRule accumulator (Just error') = pure $ accumulator |> error'
@ -67,7 +63,7 @@ executableDefinition (DefinitionFragment definition') =
 operationDefinition :: forall m. OperationDefinition -> ValidateT m
 operationDefinition operation =
    let selectionSet = getSelectionSet operation
-     in visitChildSelections ruleFilter selectionSet
+     in visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
  where
    ruleFilter accumulator (OperationDefinitionRule rule) =
        mapReaderT (runRule accumulator) $ rule operation
@ -75,36 +71,54 @@ operationDefinition operation =
    getSelectionSet (SelectionSet selectionSet _) = selectionSet
    getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet

+visitChildSelections :: forall  m
+    . (Seq Error -> Rule m -> ValidateT m)
+    -> ValidateT m
+    -> ValidateT m
+visitChildSelections ruleFilter children' = do
+    rules' <- asks rules
+    applied <- foldM ruleFilter Seq.empty rules'
+    children <- children'
+    pure $ children >< applied
+
 selection :: forall m. Selection -> ValidateT m
 selection selection'
-    | FragmentSpread{} <- selection' =
-        asks rules >>= foldM ruleFilter Seq.empty
+    | FragmentSpreadSelection fragmentSelection <- selection' =
+        visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
    | Field _ _ _ _ selectionSet _ <- selection' =
-        visitChildSelections ruleFilter selectionSet
-    | InlineFragment _ _ selectionSet _ <- selection' =
-        visitChildSelections ruleFilter selectionSet
+        visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
+    | InlineFragmentSelection fragmentSelection <- selection' =
+        visitChildSelections ruleFilter $ inlineFragment fragmentSelection
  where
    ruleFilter accumulator (SelectionRule rule) =
        mapReaderT (runRule accumulator) $ rule selection'
    ruleFilter accumulator _ = pure accumulator

+inlineFragment :: forall m. InlineFragment -> ValidateT m
+inlineFragment fragment@(InlineFragment _ _ selections _) =
+    visitChildSelections ruleFilter $ traverseSelectionSet selections
+  where
+    ruleFilter accumulator (FragmentRule _ inlineRule) =
+        mapReaderT (runRule accumulator) $ inlineRule fragment
+    ruleFilter accumulator _ = pure accumulator
+
+fragmentSpread :: forall m. FragmentSpread -> ValidateT m
+fragmentSpread fragment =
+    asks rules >>= foldM ruleFilter Seq.empty
+  where
+    ruleFilter accumulator (FragmentSpreadRule rule) =
+        mapReaderT (runRule accumulator) $ rule fragment
+    ruleFilter accumulator _ = pure accumulator
+
 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
+    visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
  where
    ruleFilter accumulator (FragmentDefinitionRule rule) =
        mapReaderT (runRule accumulator) $ rule fragment
+    ruleFilter accumulator (FragmentRule definitionRule _) =
+        mapReaderT (runRule accumulator) $ definitionRule fragment
    ruleFilter accumulator _ = pure accumulator
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@ -10,6 +10,7 @@
 -- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
    ( executableDefinitionsRule
+    , fragmentsOnCompositeTypesRule
    , fragmentSpreadTargetDefinedRule
    , fragmentSpreadTypeExistenceRule
    , loneAnonymousOperationRule
@ -46,6 +47,7 @@ specifiedRules =
    , uniqueFragmentNamesRule
    , fragmentSpreadTargetDefinedRule
    , fragmentSpreadTypeExistenceRule
+    , fragmentsOnCompositeTypesRule
    ]

 -- | Definition must be OperationDefinition or FragmentDefinition.
@ -89,24 +91,29 @@ 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 _ _)
-        | any skip directives = pure accumulator
-        | Just aliasedName <- alias = pure
-            $ HashSet.insert aliasedName accumulator
-        | otherwise = pure $ HashSet.insert name accumulator
-    forEach accumulator (FragmentSpread fragmentName directives _)
+    forEach accumulator = \case
+        Field alias name _ directives _ _
+            | any skip directives -> pure accumulator
+            | Just aliasedName <- alias -> pure
+                $ HashSet.insert aliasedName accumulator
+            | otherwise -> pure $ HashSet.insert name accumulator
+        FragmentSpreadSelection fragmentSelection ->
+            forSpread accumulator fragmentSelection
+        InlineFragmentSelection fragmentSelection ->
+            forInline accumulator fragmentSelection
+    forSpread accumulator (FragmentSpread fragmentName directives _)
        | any skip directives = pure accumulator
        | otherwise = do
            inVisitetFragments <- gets $ HashSet.member fragmentName
            if inVisitetFragments
               then pure accumulator
               else collectFromSpread fragmentName accumulator
-    forEach accumulator (InlineFragment typeCondition' directives selectionSet _)
+    forInline accumulator (InlineFragment maybeType directives selections _)
        | any skip directives = pure accumulator
-        | Just typeCondition <- typeCondition' =
-            collectFromFragment typeCondition selectionSet accumulator
+        | Just typeCondition <- maybeType =
+            collectFromFragment typeCondition selections accumulator
        | otherwise = HashSet.union accumulator
-            <$> collectFields selectionSet
+            <$> collectFields selections
    skip (Directive "skip" [Argument "if" (Boolean True)]) = True
    skip (Directive "include" [Argument "if" (Boolean False)]) = True
    skip _ = False
@ -233,7 +240,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
 -- | 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
+fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
    FragmentSpread fragmentName _ location -> do
        ast' <- asks ast
        case find (isSpreadTarget fragmentName) ast' of
@ -243,7 +250,6 @@ fragmentSpreadTargetDefinedRule = SelectionRule $ \case
                , path = []
                }
            Just _ -> lift Nothing
-    _ -> lift Nothing
  where
    error' fragmentName = concat
        [ "Fragment target \""
@ -262,27 +268,30 @@ isSpreadTarget _ _ = False
 -- the query does not validate.
 fragmentSpreadTypeExistenceRule :: forall m. Rule m
 fragmentSpreadTypeExistenceRule = SelectionRule $ \case
-    FragmentSpread fragmentName _ location -> do
-        ast' <- asks ast
-        target <- lift $ find (isSpreadTarget fragmentName) ast'
-        typeCondition <- extractTypeCondition target
-        types' <- asks types
-        case HashMap.lookup typeCondition types' of
-            Nothing -> pure $ Error
-                { 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 = []
-                }
-            Just _ -> lift Nothing
+    FragmentSpreadSelection fragmentSelection
+        | FragmentSpread fragmentName _ location <- fragmentSelection -> do
+            ast' <- asks ast
+            target <- lift $ find (isSpreadTarget fragmentName) ast'
+            typeCondition <- extractTypeCondition target
+            types' <- asks types
+            case HashMap.lookup typeCondition types' of
+                Nothing -> pure $ Error
+                    { message = spreadError fragmentName typeCondition
+                    , locations = [location]
+                    , path = []
+                    }
+                Just _ -> lift Nothing
+    InlineFragmentSelection fragmentSelection
+        | InlineFragment maybeType _ _ location <- fragmentSelection
+        , Just typeCondition <- maybeType -> do
+            types' <- asks types
+            case HashMap.lookup typeCondition types' of
+                Nothing -> pure $ Error
+                    { message = inlineError typeCondition
+                    , locations = [location]
+                    , path = []
+                    }
+                Just _ -> lift Nothing
    _ -> lift Nothing
  where
    extractTypeCondition (viewFragment -> Just fragmentDefinition) =
@ -301,3 +310,31 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
        , Text.unpack typeCondition
        , "\" which doesn't exist in the schema."
        ]
+
+-- | Fragments can only be declared on unions, interfaces, and objects. They are
+-- invalid on scalars. They can only be applied on non‐leaf fields. This rule
+-- applies to both inline and named fragments.
+fragmentsOnCompositeTypesRule :: forall m. Rule m
+fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
+  where
+    inlineRule (InlineFragment (Just typeCondition) _ _ location) =
+        check typeCondition location
+    inlineRule _ = lift Nothing
+    definitionRule (FragmentDefinition _ typeCondition _ _ location) =
+        check typeCondition location
+    check typeCondition location = do
+        types' <- asks types
+        -- Skip unknown types, they are checked by another rule.
+        _ <- lift $ HashMap.lookup typeCondition types'
+        case lookupTypeCondition typeCondition types' of
+            Nothing -> pure $ Error
+                { message = errorMessage typeCondition
+                , locations = [location]
+                , path = []
+                }
+            Just _ -> lift Nothing
+    errorMessage typeCondition = concat
+        [ "Fragment cannot condition on non composite type \""
+        , Text.unpack typeCondition,
+        "\"."
+        ]
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@ -50,6 +50,8 @@ data Rule m
    | OperationDefinitionRule (OperationDefinition -> RuleT m)
    | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
    | SelectionRule (Selection -> RuleT m)
+    | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
+    | FragmentSpreadRule (FragmentSpread -> RuleT m)

 -- | Monad transformer used by the rules.
 type RuleT m = ReaderT (Validation m) Maybe Error
--- a/stack.yaml
+++ b/stack.yaml
@ -1,4 +1,4 @@
-resolver: lts-16.12
+resolver: lts-16.13

 packages:
 - .
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@ -336,3 +336,40 @@ spec =
                    , path = []
                    }
             in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects fragments on scalar types" $
+            let queryString = [r|
+              {
+                dog {
+                  ...fragOnScalar
+                }
+              }
+              fragment fragOnScalar on Int {
+                name
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment cannot condition on non composite type \
+                        \\"Int\"."
+                    , locations = [AST.Location 7 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects inline fragments on scalar types" $
+            let queryString = [r|
+              {
+                ... on Boolean {
+                  name
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment cannot condition on non composite type \
+                        \\"Boolean\"."
+                    , locations = [AST.Location 3 17]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected