Validate fragment name uniqueness

5 files changed, 86 insertions, 20 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index d1b5216..2e45f6d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -17,6 +17,7 @@ and this project adheres to
 ## 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
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index bcc3bf7..53dc6f9 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -66,11 +66,16 @@ executableDefinition (DefinitionFragment definition') =
 
 operationDefinition :: forall m. OperationDefinition -> ValidateT m
 operationDefinition operation =
-    asks rules >>= foldM (ruleFilter operation) Seq.empty
+    asks rules >>= foldM ruleFilter Seq.empty
   where
-    ruleFilter definition' accumulator (OperationDefinitionRule rule) =
-        mapReaderT (runRule accumulator) $ rule definition'
-    ruleFilter _ accumulator _ = pure accumulator
+    ruleFilter accumulator (OperationDefinitionRule rule) =
+        mapReaderT (runRule accumulator) $ rule operation
+    ruleFilter accumulator _ = pure accumulator
 
 fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
-fragmentDefinition _fragment = pure Seq.empty
+fragmentDefinition fragment =
+    asks rules >>= foldM ruleFilter Seq.empty
+  where
+    ruleFilter accumulator (FragmentDefinitionRule rule) =
+        mapReaderT (runRule accumulator) $ rule fragment
+    ruleFilter accumulator _ = pure accumulator
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 4994f5c..690631e 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -13,6 +13,7 @@ module Language.GraphQL.Validate.Rules
     , loneAnonymousOperationRule
     , singleFieldSubscriptionsRule
     , specifiedRules
+    , uniqueFragmentNamesRule
     , uniqueOperationNamesRule
     ) where
 
@@ -34,6 +35,7 @@ specifiedRules =
     , singleFieldSubscriptionsRule
     , loneAnonymousOperationRule
     , uniqueOperationNamesRule
+    , uniqueFragmentNamesRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
@@ -151,32 +153,63 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
 -- referred to by its name.
 uniqueOperationNamesRule :: forall m. Rule m
 uniqueOperationNamesRule = OperationDefinitionRule $ \case
-    OperationDefinition _ (Just thisName) _ _ _ thisLocation -> do
-        ast' <- asks ast
-        let locations' = foldr (filterByName thisName) [] ast'
-        if length locations' > 1 && head locations' == thisLocation
-            then pure $ error' thisName locations'
-            else lift Nothing
+    OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
+        findDuplicates (filterByName thisName) thisLocation (error' thisName)
     _ -> lift Nothing
   where
-    error' operationName locations' = Error 
-        { message = concat
-            [ "There can be only one operation named \""
-            , Text.unpack operationName
-            , "\"."
-            ]
-        , locations = locations'
-        , path = []
-        }
+    error' operationName = concat
+        [ "There can be only one operation named \""
+        , Text.unpack operationName
+        , "\"."
+        ]
     filterByName thisName definition' accumulator
         | (viewOperation -> Just operationDefinition) <- definition'
         , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
         , thisName == thatName = thatLocation : accumulator
         | otherwise = accumulator
 
+findDuplicates :: (Definition -> [Location] -> [Location])
+    -> Location
+    -> String
+    -> RuleT m
+findDuplicates filterByName thisLocation errorMessage = do
+    ast' <- asks ast
+    let locations' = foldr filterByName [] ast'
+    if length locations' > 1 && head locations' == thisLocation
+        then pure $ error' locations'
+        else lift Nothing
+  where
+    error' locations' = Error 
+        { message = errorMessage
+        , locations = locations'
+        , path = []
+        }
+
 viewOperation :: Definition -> Maybe OperationDefinition
 viewOperation definition
     | ExecutableDefinition executableDefinition <- definition
     , DefinitionOperation operationDefinition <- executableDefinition =
         Just operationDefinition
 viewOperation _ = Nothing
+
+-- | Fragment definitions are referenced in fragment spreads by name. To avoid
+-- ambiguity, each fragment’s name must be unique within a document.
+--
+-- Inline fragments are not considered fragment definitions, and are unaffected
+-- by this validation rule.
+uniqueFragmentNamesRule :: forall m. Rule m
+uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
+    FragmentDefinition thisName _ _ _ thisLocation ->
+        findDuplicates (filterByName thisName) thisLocation (error' thisName)
+  where
+    error' fragmentName = concat
+        [ "There can be only one fragment named \""
+        , Text.unpack fragmentName
+        , "\"."
+        ]
+    filterByName thisName definition accumulator
+        | ExecutableDefinition executableDefinition <- definition
+        , DefinitionFragment fragmentDefinition <- executableDefinition
+        , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
+        , thisName == thatName = thatLocation : accumulator
+        | otherwise = accumulator
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index 2b5365a..03bbf33 100644
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@@ -48,6 +48,7 @@ data Validation m = Validation
 data Rule m
     = DefinitionRule (Definition -> RuleT m)
     | OperationDefinitionRule (OperationDefinition -> RuleT m)
+    | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
 
 -- | Monad transformer used by the rules.
 type RuleT m = ReaderT (Validation m) Maybe Error
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index a547e21..8f6626b 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -255,3 +255,29 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects fragments with the same name" $
+            let queryString = [r|
+              {
+                dog {
+                  ...fragmentOne
+                }
+              }
+
+              fragment fragmentOne on Dog {
+                name
+              }
+
+              fragment fragmentOne on Dog {
+                owner {
+                  name
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "There can be only one fragment named \"fragmentOne\"."
+                    , locations = [AST.Location 8 15, AST.Location 12 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected