Validate operation name uniqueness

Fixes #52.
This commit is contained in:
Eugen Wissner 2020-08-27 09:04:31 +02:00
parent e6a6926e18
commit eebad8a27f
4 changed files with 128 additions and 66 deletions

View File

@ -18,7 +18,6 @@ import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
import Data.Foldable (foldrM) import Data.Foldable (foldrM)
import Data.Sequence (Seq(..), (><), (|>)) import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text)
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Internal
import Language.GraphQL.Type.Schema (Schema(..)) import Language.GraphQL.Type.Schema (Schema(..))
@ -27,22 +26,6 @@ import Language.GraphQL.Validate.Validation
type ValidateT m = Reader (Validation m) (Seq Error) 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 -- | Validates a document and returns a list of found errors. If the returned
-- list is empty, the document is valid. -- list is empty, the document is valid.
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
@ -68,25 +51,12 @@ definition = \case
applyRules definition' = applyRules definition' =
asks rules >>= foldM (ruleFilter definition') Seq.empty asks rules >>= foldM (ruleFilter definition') Seq.empty
ruleFilter definition' accumulator (DefinitionRule rule) = ruleFilter definition' accumulator (DefinitionRule rule) =
flip mapReaderT (rule definition') $ \case mapReaderT (runRule accumulator) $ rule definition'
Just message' ->
pure $ accumulator |> Error
{ message = message'
, locations = [definitionLocation definition']
, path = []
}
Nothing -> pure accumulator
ruleFilter _ accumulator _ = pure accumulator ruleFilter _ accumulator _ = pure accumulator
definitionLocation (ExecutableDefinition executableDefinition')
| DefinitionOperation definitionOperation <- executableDefinition' runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
, SelectionSet _ location <- definitionOperation = location runRule accumulator (Just error') = pure $ accumulator |> error'
| DefinitionOperation definitionOperation <- executableDefinition' runRule accumulator Nothing = pure accumulator
, OperationDefinition _ _ _ _ _ location <- definitionOperation =
location
| DefinitionFragment fragmentDefinition' <- executableDefinition'
, FragmentDefinition _ _ _ _ location <- fragmentDefinition' = location
definitionLocation (TypeSystemDefinition _ location) = location
definitionLocation (TypeSystemExtension _ location) = location
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
executableDefinition (DefinitionOperation definition') = executableDefinition (DefinitionOperation definition') =
@ -99,17 +69,8 @@ operationDefinition operation =
asks rules >>= foldM (ruleFilter operation) Seq.empty asks rules >>= foldM (ruleFilter operation) Seq.empty
where where
ruleFilter definition' accumulator (OperationDefinitionRule rule) = ruleFilter definition' accumulator (OperationDefinitionRule rule) =
flip mapReaderT (rule definition') $ \case mapReaderT (runRule accumulator) $ rule definition'
Just message' ->
pure $ accumulator |> Error
{ message = message'
, locations = [definitionLocation operation]
, path = []
}
Nothing -> pure accumulator
ruleFilter _ accumulator _ = pure accumulator ruleFilter _ accumulator _ = pure accumulator
definitionLocation (SelectionSet _ location) = location
definitionLocation (OperationDefinition _ _ _ _ _ location) = location
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition _fragment = pure Seq.empty fragmentDefinition _fragment = pure Seq.empty

View File

@ -5,11 +5,15 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-- | This module contains default rules defined in the GraphQL specification. -- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules module Language.GraphQL.Validate.Rules
( executableDefinitionsRule ( executableDefinitionsRule
, loneAnonymousOperationRule
, singleFieldSubscriptionsRule
, specifiedRules , specifiedRules
, uniqueOperationNamesRule
) where ) where
import Control.Monad (foldM) import Control.Monad (foldM)
@ -29,31 +33,49 @@ specifiedRules =
[ executableDefinitionsRule [ executableDefinitionsRule
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, uniqueOperationNamesRule
] ]
-- | Definition must be OperationDefinition or FragmentDefinition. -- | Definition must be OperationDefinition or FragmentDefinition.
executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule :: forall m. Rule m
executableDefinitionsRule = DefinitionRule $ \case executableDefinitionsRule = DefinitionRule $ \case
ExecutableDefinition _ -> lift Nothing 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. -- | Subscription operations must have exactly one root field.
singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
OperationDefinition Subscription name' _ _ rootFields _ -> do OperationDefinition Subscription name' _ _ rootFields location -> do
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
case HashSet.size groupedFieldSet of case HashSet.size groupedFieldSet of
1 -> lift Nothing 1 -> lift Nothing
_ _
| Just name <- name' -> pure $ unwords | Just name <- name' -> pure $ Error
{ message = unwords
[ "Subscription" [ "Subscription"
, Text.unpack name , Text.unpack name
, "must select only one top level field." , "must select only one top level field."
] ]
| otherwise -> pure , locations = [location]
"Anonymous Subscription must select only one top level field." , path = []
}
| otherwise -> pure $ Error
{ message = errorMessage
, locations = [location]
, path = []
}
_ -> lift Nothing _ -> lift Nothing
where where
errorMessage =
"Anonymous Subscription must select only one top level field."
collectFields selectionSet = foldM forEach HashSet.empty selectionSet collectFields selectionSet = foldM forEach HashSet.empty selectionSet
forEach accumulator (Field alias name _ directives _) forEach accumulator (Field alias name _ directives _)
| any skip directives = pure accumulator | any skip directives = pure accumulator
@ -109,14 +131,52 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
check thisLocation = asks ast check thisLocation = asks ast
>>= lift . foldr (filterAnonymousOperations thisLocation) Nothing >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
filterAnonymousOperations thisLocation definition Nothing filterAnonymousOperations thisLocation definition Nothing
| ExecutableDefinition executableDefinition <- definition | (viewOperation -> Just operationDefinition) <- definition =
, DefinitionOperation operationDefinition <- executableDefinition =
compareAnonymousOperations thisLocation operationDefinition compareAnonymousOperations thisLocation operationDefinition
filterAnonymousOperations _ _ accumulator = accumulator filterAnonymousOperations _ _ accumulator = accumulator
compareAnonymousOperations thisLocation operationDefinition compareAnonymousOperations thisLocation = \case
| OperationDefinition _ _ _ _ _ thatLocation <- operationDefinition OperationDefinition _ _ _ _ _ thatLocation
, thisLocation /= thatLocation = pure message | thisLocation /= thatLocation -> pure $ error' thisLocation
| SelectionSet _ thatLocation <- operationDefinition SelectionSet _ thatLocation
, thisLocation /= thatLocation = pure message | thisLocation /= thatLocation -> pure $ error' thisLocation
compareAnonymousOperations _ _ = Nothing _ -> Nothing
message = "This anonymous operation must be the only defined operation." 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

View File

@ -4,17 +4,36 @@
-- | Definitions used by the validation rules and the validator itself. -- | Definitions used by the validation rules and the validator itself.
module Language.GraphQL.Validate.Validation module Language.GraphQL.Validate.Validation
( Validation(..) ( Error(..)
, Path(..)
, Rule(..) , Rule(..)
, RuleT , RuleT
, Validation(..)
) where ) where
import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Reader (ReaderT(..))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Schema (Schema) import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as 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. -- | Validation rule context.
data Validation m = Validation data Validation m = Validation
{ ast :: Document { ast :: Document
@ -31,4 +50,4 @@ data Rule m
| OperationDefinitionRule (OperationDefinition -> RuleT m) | OperationDefinitionRule (OperationDefinition -> RuleT m)
-- | Monad transformer used by the rules. -- | Monad transformer used by the rules.
type RuleT m = ReaderT (Validation m) Maybe String type RuleT m = ReaderT (Validation m) Maybe Error

View File

@ -233,3 +233,25 @@ spec =
, path = [] , path = []
} }
in validate queryString `shouldBe` Seq.singleton expected 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