forked from OSS/graphql
Use Seq as base monad in the validator
It is more natural to implement the logic: try to apply each rule to each node.
This commit is contained in:
@ -33,6 +33,7 @@ import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (sortBy)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document
|
||||
@ -61,7 +62,7 @@ specifiedRules =
|
||||
-- | Definition must be OperationDefinition or FragmentDefinition.
|
||||
executableDefinitionsRule :: forall m. Rule m
|
||||
executableDefinitionsRule = DefinitionRule $ \case
|
||||
ExecutableDefinition _ -> lift Nothing
|
||||
ExecutableDefinition _ -> lift mempty
|
||||
TypeSystemDefinition _ location -> pure $ error' location
|
||||
TypeSystemExtension _ location -> pure $ error' location
|
||||
where
|
||||
@ -78,7 +79,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||
OperationDefinition Subscription name' _ _ rootFields location -> do
|
||||
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
|
||||
case HashSet.size groupedFieldSet of
|
||||
1 -> lift Nothing
|
||||
1 -> lift mempty
|
||||
_
|
||||
| Just name <- name' -> pure $ Error
|
||||
{ message = unwords
|
||||
@ -94,7 +95,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||
, locations = [location]
|
||||
, path = []
|
||||
}
|
||||
_ -> lift Nothing
|
||||
_ -> lift mempty
|
||||
where
|
||||
errorMessage =
|
||||
"Anonymous Subscription must select only one top level field."
|
||||
@ -123,8 +124,8 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||
collectFromFragment typeCondition selections accumulator
|
||||
| otherwise = HashSet.union accumulator
|
||||
<$> collectFields selections
|
||||
skip (Directive "skip" [Argument "if" (Boolean True)]) = True
|
||||
skip (Directive "include" [Argument "if" (Boolean False)]) = True
|
||||
skip (Directive "skip" [Argument "if" (Boolean True) _]) = True
|
||||
skip (Directive "include" [Argument "if" (Boolean False) _]) = True
|
||||
skip _ = False
|
||||
findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
|
||||
| DefinitionFragment fragmentDefinition <- executableDefinition =
|
||||
@ -154,11 +155,11 @@ loneAnonymousOperationRule :: forall m. Rule m
|
||||
loneAnonymousOperationRule = OperationDefinitionRule $ \case
|
||||
SelectionSet _ thisLocation -> check thisLocation
|
||||
OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation
|
||||
_ -> lift Nothing
|
||||
_ -> lift mempty
|
||||
where
|
||||
check thisLocation = asks ast
|
||||
>>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
|
||||
filterAnonymousOperations thisLocation definition Nothing
|
||||
>>= lift . foldr (filterAnonymousOperations thisLocation) mempty
|
||||
filterAnonymousOperations thisLocation definition Empty
|
||||
| (viewOperation -> Just operationDefinition) <- definition =
|
||||
compareAnonymousOperations thisLocation operationDefinition
|
||||
filterAnonymousOperations _ _ accumulator = accumulator
|
||||
@ -167,7 +168,7 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
|
||||
| thisLocation /= thatLocation -> pure $ error' thisLocation
|
||||
SelectionSet _ thatLocation
|
||||
| thisLocation /= thatLocation -> pure $ error' thisLocation
|
||||
_ -> Nothing
|
||||
_ -> mempty
|
||||
error' location = Error
|
||||
{ message =
|
||||
"This anonymous operation must be the only defined operation."
|
||||
@ -181,7 +182,7 @@ uniqueOperationNamesRule :: forall m. Rule m
|
||||
uniqueOperationNamesRule = OperationDefinitionRule $ \case
|
||||
OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
|
||||
findDuplicates (filterByName thisName) thisLocation (error' thisName)
|
||||
_ -> lift Nothing
|
||||
_ -> lift mempty
|
||||
where
|
||||
error' operationName = concat
|
||||
[ "There can be only one operation named \""
|
||||
@ -203,7 +204,7 @@ findDuplicates filterByName thisLocation errorMessage = do
|
||||
let locations' = foldr filterByName [] ast'
|
||||
if length locations' > 1 && head locations' == thisLocation
|
||||
then pure $ error' locations'
|
||||
else lift Nothing
|
||||
else lift mempty
|
||||
where
|
||||
error' locations' = Error
|
||||
{ message = errorMessage
|
||||
@ -258,7 +259,7 @@ fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
|
||||
, locations = [location]
|
||||
, path = []
|
||||
}
|
||||
Just _ -> lift Nothing
|
||||
Just _ -> lift mempty
|
||||
where
|
||||
error' fragmentName = concat
|
||||
[ "Fragment target \""
|
||||
@ -280,8 +281,8 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
|
||||
FragmentSpreadSelection fragmentSelection
|
||||
| FragmentSpread fragmentName _ location <- fragmentSelection -> do
|
||||
ast' <- asks ast
|
||||
target <- lift $ find (isSpreadTarget fragmentName) ast'
|
||||
typeCondition <- extractTypeCondition target
|
||||
let target = find (isSpreadTarget fragmentName) ast'
|
||||
typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition
|
||||
types' <- asks types
|
||||
case HashMap.lookup typeCondition types' of
|
||||
Nothing -> pure $ Error
|
||||
@ -289,7 +290,7 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
|
||||
, locations = [location]
|
||||
, path = []
|
||||
}
|
||||
Just _ -> lift Nothing
|
||||
Just _ -> lift mempty
|
||||
InlineFragmentSelection fragmentSelection
|
||||
| InlineFragment maybeType _ _ location <- fragmentSelection
|
||||
, Just typeCondition <- maybeType -> do
|
||||
@ -300,13 +301,13 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
|
||||
, locations = [location]
|
||||
, path = []
|
||||
}
|
||||
Just _ -> lift Nothing
|
||||
_ -> lift Nothing
|
||||
Just _ -> lift mempty
|
||||
_ -> lift mempty
|
||||
where
|
||||
extractTypeCondition (viewFragment -> Just fragmentDefinition) =
|
||||
let FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
|
||||
in pure typeCondition
|
||||
extractTypeCondition _ = lift Nothing
|
||||
in Just typeCondition
|
||||
extractTypeCondition _ = Nothing
|
||||
spreadError fragmentName typeCondition = concat
|
||||
[ "Fragment \""
|
||||
, Text.unpack fragmentName
|
||||
@ -320,6 +321,10 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
|
||||
, "\" which doesn't exist in the schema."
|
||||
]
|
||||
|
||||
maybeToSeq :: forall a. Maybe a -> Seq a
|
||||
maybeToSeq (Just x) = pure x
|
||||
maybeToSeq Nothing = mempty
|
||||
|
||||
-- | Fragments can only be declared on unions, interfaces, and objects. They are
|
||||
-- invalid on scalars. They can only be applied on non‐leaf fields. This rule
|
||||
-- applies to both inline and named fragments.
|
||||
@ -328,20 +333,20 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
|
||||
where
|
||||
inlineRule (InlineFragment (Just typeCondition) _ _ location) =
|
||||
check typeCondition location
|
||||
inlineRule _ = lift Nothing
|
||||
inlineRule _ = lift mempty
|
||||
definitionRule (FragmentDefinition _ typeCondition _ _ location) =
|
||||
check typeCondition location
|
||||
check typeCondition location = do
|
||||
types' <- asks types
|
||||
-- Skip unknown types, they are checked by another rule.
|
||||
_ <- lift $ HashMap.lookup typeCondition types'
|
||||
_ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'
|
||||
case lookupTypeCondition typeCondition types' of
|
||||
Nothing -> pure $ Error
|
||||
{ message = errorMessage typeCondition
|
||||
, locations = [location]
|
||||
, path = []
|
||||
}
|
||||
Just _ -> lift Nothing
|
||||
Just _ -> lift mempty
|
||||
errorMessage typeCondition = concat
|
||||
[ "Fragment cannot condition on non composite type \""
|
||||
, Text.unpack typeCondition,
|
||||
@ -354,7 +359,7 @@ noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment ->
|
||||
asks ast >>= findSpreadByName fragment
|
||||
where
|
||||
findSpreadByName (FragmentDefinition fragName _ _ _ location) definitions
|
||||
| foldr (go fragName) False definitions = lift Nothing
|
||||
| foldr (go fragName) False definitions = lift mempty
|
||||
| otherwise = pure $ Error
|
||||
{ message = errorMessage fragName
|
||||
, locations = [location]
|
||||
@ -410,12 +415,12 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||
, locations = [location]
|
||||
, path = []
|
||||
}
|
||||
_ -> lift Nothing
|
||||
_ -> lift mempty
|
||||
where
|
||||
collectFields :: Traversable t
|
||||
=> forall m
|
||||
. t Selection
|
||||
-> StateT (Int, Name) (ReaderT (Validation m) Maybe) (HashMap Name Int)
|
||||
-> StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
|
||||
collectFields selectionSet = foldM forEach HashMap.empty selectionSet
|
||||
forEach accumulator = \case
|
||||
FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||||
|
||||
@ -11,8 +11,9 @@ module Language.GraphQL.Validate.Validation
|
||||
, Validation(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Reader (ReaderT(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
@ -39,7 +40,6 @@ data Validation m = Validation
|
||||
{ ast :: Document
|
||||
, schema :: Schema m
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
, rules :: [Rule m]
|
||||
}
|
||||
|
||||
-- | 'Rule' assigns a function to each AST node that can be validated. If the
|
||||
@ -55,4 +55,4 @@ data Rule m
|
||||
| FieldRule (Field -> RuleT m)
|
||||
|
||||
-- | Monad transformer used by the rules.
|
||||
type RuleT m = ReaderT (Validation m) Maybe Error
|
||||
type RuleT m = ReaderT (Validation m) Seq Error
|
||||
|
||||
Reference in New Issue
Block a user