Validate operation name uniqueness

Fixes #52.

4 files changed, 128 insertions, 66 deletions

diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 95f7462..bcc3bf7 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -18,7 +18,6 @@ import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
 import Data.Foldable (foldrM)
 import Data.Sequence (Seq(..), (><), (|>))
 import qualified Data.Sequence as Seq
-import Data.Text (Text)
 import Language.GraphQL.AST.Document
 import Language.GraphQL.Type.Internal
 import Language.GraphQL.Type.Schema (Schema(..))
@@ -27,22 +26,6 @@ import Language.GraphQL.Validate.Validation
 
 type ValidateT m = Reader (Validation m) (Seq Error)
 
--- | If an error can be associated to a particular field in the GraphQL result,
--- it must contain an entry with the key path that details the path of the
--- response field which experienced the error. This allows clients to identify
--- whether a null result is intentional or caused by a runtime error.
-data Path
-    = Segment Text -- ^ Field name.
-    | Index Int -- ^ List index if a field returned a list.
-    deriving (Eq, Show)
-
--- | Validation error.
-data Error = Error
-    { message :: String
-    , locations :: [Location]
-    , path :: [Path]
-    } deriving (Eq, Show)
-
 -- | Validates a document and returns a list of found errors. If the returned
 -- list is empty, the document is valid.
 document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
@@ -68,25 +51,12 @@ definition = \case
     applyRules definition' =
         asks rules >>= foldM (ruleFilter definition') Seq.empty
     ruleFilter definition' accumulator (DefinitionRule rule) =
-        flip mapReaderT (rule definition') $ \case
-            Just message' ->
-                pure $ accumulator |> Error
-                    { message = message'
-                    , locations = [definitionLocation definition']
-                    , path = []
-                    }
-            Nothing -> pure accumulator
+        mapReaderT (runRule accumulator) $ rule definition'
     ruleFilter _ accumulator _ = pure accumulator
-    definitionLocation (ExecutableDefinition executableDefinition')
-        | DefinitionOperation definitionOperation <- executableDefinition'
-        , SelectionSet _ location <- definitionOperation = location
-        | DefinitionOperation definitionOperation <- executableDefinition'
-        , OperationDefinition _ _ _ _ _ location <- definitionOperation =
-            location
-        | DefinitionFragment fragmentDefinition' <- executableDefinition'
-        , FragmentDefinition _ _ _ _ location <- fragmentDefinition' = location
-    definitionLocation (TypeSystemDefinition _ location) = location
-    definitionLocation (TypeSystemExtension _ location) = location
+
+runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
+runRule accumulator (Just error') = pure $ accumulator |> error'
+runRule accumulator Nothing = pure accumulator
 
 executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
 executableDefinition (DefinitionOperation definition') =
@@ -99,17 +69,8 @@ operationDefinition operation =
     asks rules >>= foldM (ruleFilter operation) Seq.empty
   where
     ruleFilter definition' accumulator (OperationDefinitionRule rule) =
-        flip mapReaderT (rule definition') $ \case
-            Just message' ->
-                pure $ accumulator |> Error
-                    { message = message'
-                    , locations = [definitionLocation operation]
-                    , path = []
-                    }
-            Nothing -> pure accumulator
+        mapReaderT (runRule accumulator) $ rule definition'
     ruleFilter _ accumulator _ = pure accumulator
-    definitionLocation (SelectionSet _ location) = location
-    definitionLocation (OperationDefinition _ _ _ _ _ location) = location
 
 fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
 fragmentDefinition _fragment = pure Seq.empty
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 466dcae..4994f5c 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -5,11 +5,15 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
     ( executableDefinitionsRule
+    , loneAnonymousOperationRule
+    , singleFieldSubscriptionsRule
     , specifiedRules
+    , uniqueOperationNamesRule
     ) where
 
 import Control.Monad (foldM)
@@ -29,31 +33,49 @@ specifiedRules =
     [ executableDefinitionsRule
     , singleFieldSubscriptionsRule
     , loneAnonymousOperationRule
+    , uniqueOperationNamesRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
 executableDefinitionsRule :: forall m. Rule m
 executableDefinitionsRule = DefinitionRule $ \case
     ExecutableDefinition _ -> lift Nothing
-    _ -> pure "Definition must be OperationDefinition or FragmentDefinition."
+    TypeSystemDefinition _ location -> pure $ error' location
+    TypeSystemExtension _ location -> pure $ error' location
+  where
+    error' location = Error
+        { message =
+            "Definition must be OperationDefinition or FragmentDefinition."
+        , locations = [location]
+        , path = []
+        }
 
 -- | Subscription operations must have exactly one root field.
 singleFieldSubscriptionsRule :: forall m. Rule m
 singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
-    OperationDefinition Subscription name' _ _ rootFields _ -> do
+    OperationDefinition Subscription name' _ _ rootFields location -> do
         groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
         case HashSet.size groupedFieldSet of
             1 -> lift Nothing
             _
-                | Just name <- name' -> pure $ unwords
-                    [ "Subscription"
-                    , Text.unpack name
-                    , "must select only one top level field."
-                    ]
-                | otherwise -> pure
-                    "Anonymous Subscription must select only one top level field."
+                | Just name <- name' -> pure $ Error
+                    { message = unwords
+                        [ "Subscription"
+                        , Text.unpack name
+                        , "must select only one top level field."
+                        ]
+                    , locations = [location]
+                    , path = []
+                    }
+                | otherwise -> pure $ Error
+                    { message = errorMessage
+                    , locations = [location]
+                    , path = []
+                    }
     _ -> lift Nothing
   where
+    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
@@ -107,16 +129,54 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
       _ -> lift Nothing
     where
       check thisLocation = asks ast
-        >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
+          >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
       filterAnonymousOperations thisLocation definition Nothing
-          | ExecutableDefinition executableDefinition <- definition
-          , DefinitionOperation operationDefinition <- executableDefinition =
+          | (viewOperation -> Just operationDefinition) <- definition =
               compareAnonymousOperations thisLocation operationDefinition
       filterAnonymousOperations _ _ accumulator = accumulator
-      compareAnonymousOperations thisLocation operationDefinition
-          | OperationDefinition _ _ _ _ _ thatLocation <- operationDefinition
-          , thisLocation /= thatLocation = pure message
-          | SelectionSet _ thatLocation <- operationDefinition
-          , thisLocation /= thatLocation = pure message
-      compareAnonymousOperations _ _ = Nothing
-      message = "This anonymous operation must be the only defined operation."
+      compareAnonymousOperations thisLocation = \case
+          OperationDefinition _ _ _ _ _ thatLocation
+              | thisLocation /= thatLocation -> pure $ error' thisLocation
+          SelectionSet _ thatLocation
+              | thisLocation /= thatLocation -> pure $ error' thisLocation
+          _ -> Nothing
+      error' location = Error
+          { message =
+              "This anonymous operation must be the only defined operation."
+          , locations = [location]
+          , path = []
+          }
+
+-- | Each named operation definition must be unique within a document when
+-- 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
+    _ -> lift Nothing
+  where
+    error' operationName locations' = Error 
+        { message = concat
+            [ "There can be only one operation named \""
+            , Text.unpack operationName
+            , "\"."
+            ]
+        , locations = locations'
+        , path = []
+        }
+    filterByName thisName definition' accumulator
+        | (viewOperation -> Just operationDefinition) <- definition'
+        , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
+        , thisName == thatName = thatLocation : accumulator
+        | otherwise = accumulator
+
+viewOperation :: Definition -> Maybe OperationDefinition
+viewOperation definition
+    | ExecutableDefinition executableDefinition <- definition
+    , DefinitionOperation operationDefinition <- executableDefinition =
+        Just operationDefinition
+viewOperation _ = Nothing
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index f6edc7a..2b5365a 100644
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@@ -4,17 +4,36 @@
 
 -- | Definitions used by the validation rules and the validator itself.
 module Language.GraphQL.Validate.Validation
-    ( Validation(..)
+    ( Error(..)
+    , Path(..)
     , Rule(..)
     , RuleT
+    , Validation(..)
     ) where
 
 import Control.Monad.Trans.Reader (ReaderT(..))
 import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
 import Language.GraphQL.AST.Document
 import Language.GraphQL.Type.Schema (Schema)
 import qualified Language.GraphQL.Type.Schema as Schema
 
+-- | If an error can be associated to a particular field in the GraphQL result,
+-- it must contain an entry with the key path that details the path of the
+-- response field which experienced the error. This allows clients to identify
+-- whether a null result is intentional or caused by a runtime error.
+data Path
+    = Segment Text -- ^ Field name.
+    | Index Int -- ^ List index if a field returned a list.
+    deriving (Eq, Show)
+
+-- | Validation error.
+data Error = Error
+    { message :: String
+    , locations :: [Location]
+    , path :: [Path]
+    } deriving (Eq, Show)
+
 -- | Validation rule context.
 data Validation m = Validation
     { ast :: Document
@@ -31,4 +50,4 @@ data Rule m
     | OperationDefinitionRule (OperationDefinition -> RuleT m)
 
 -- | Monad transformer used by the rules.
-type RuleT m = ReaderT (Validation m) Maybe String
+type RuleT m = ReaderT (Validation m) Maybe Error
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index 4b5e638..a547e21 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -233,3 +233,25 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects operations with the same name" $
+            let queryString = [r|
+              query dogOperation {
+                dog {
+                  name
+                }
+              }
+
+              mutation dogOperation {
+                mutateDog {
+                  id
+                }
+            }
+            |]
+                expected = Error
+                    { message =
+                        "There can be only one operation named \"dogOperation\"."
+                    , locations = [AST.Location 2 15, AST.Location 8 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected