From eebad8a27f164088e356e7936afb9a399c70363a Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 27 Aug 2020 09:04:31 +0200 Subject: [PATCH] Validate operation name uniqueness Fixes #52. --- src/Language/GraphQL/Validate.hs | 51 ++--------- src/Language/GraphQL/Validate/Rules.hs | 98 +++++++++++++++++---- src/Language/GraphQL/Validate/Validation.hs | 23 ++++- tests/Language/GraphQL/ValidateSpec.hs | 22 +++++ 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