Validate operation name uniqueness

Fixes #52.
2020-08-27 09:04:31 +02:00 · 2020-08-27 09:04:31 +02:00 · eebad8a27f
commit eebad8a27f
parent e6a6926e18
4 changed files with 128 additions and 66 deletions
--- 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
--- 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
+                | Just name <- name' -> pure $ Error
+                    { message = unwords
                        [ "Subscription"
                        , Text.unpack name
                        , "must select only one top level field."
                        ]
-                | otherwise -> pure
-                    "Anonymous Subscription 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
@ -109,14 +131,52 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
      check thisLocation = asks ast
          >>= 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
--- 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
--- 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