Validate fragments on composite types

7 files changed, 167 insertions, 100 deletions

diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index f780a9d..5cfadc5 100644
--- 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
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 7428365..0757867 100644
--- 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 _)
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index af82a9e..e68956f 100644
--- 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
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index b438bdf..e36db55 100644
--- 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
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 7a25ce4..1ffa514 100644
--- 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
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 78d1901..28e12a3 100644
--- 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,
+        "\"."
+        ]
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index 21640bc..fb04b76 100644
--- 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