prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Validate operation name uniqueness

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/Language/GraphQL/Validate.hs
View File

@ -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

98
src/Language/GraphQL/Validate/Rules.hs
View File

@ -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

23
src/Language/GraphQL/Validate/Validation.hs
View File

@ -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

22
tests/Language/GraphQL/ValidateSpec.hs
View File

@ -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