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

Use Seq as base monad in the validator

Browse Source 
It is more natural to implement the logic: try to apply each rule to
each node.
This commit is contained in:
Eugen Wissner 2020-09-14 07:49:33 +02:00
parent 08998dbd93
commit 4c10ce9204
11 changed files with 123 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
CHANGELOG.md
View File

@ -10,9 +10,16 @@ and this project adheres to
### Changed
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
and `InlineFragment`. Thus validation rules can be defined more concise.
- `AST.Document.Argument` contains the argument location.
- `AST.Lexer.colon` ignores the result (it is always a colon).
- `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`
contained the list of rules, but the executed rules shouldn't know about other
rules. `rules` was a part of the `Validation` context to pass it easier
around, but since the rules are traversed once now and applied to all nodes in
the tree at the beginning, it isn't required anymore.
### Added
- `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule` and
- `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule`,
`FragmentSpreadRule` constructors.
- `Validate.Rules`:
- `fragmentsOnCompositeTypesRule`

10
src/Language/GraphQL/AST/Document.hs
View File

@ -49,7 +49,7 @@ import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST.DirectiveLocation
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
-- * Language
@ -126,7 +126,7 @@ data Selection
| InlineFragmentSelection InlineFragment
deriving (Eq, Show)
-- The only required property of a field is its name. Optionally it can also
-- | The only required property of a field is its name. Optionally it can also
-- have an alias, arguments, directives and a list of subfields.
--
-- In the following query "user" is a field with two subfields, "id" and "name":
@ -143,7 +143,7 @@ data Field =
Field (Maybe Name) Name [Argument] [Directive] SelectionSetOpt Location
deriving (Eq, Show)
-- Inline fragments don't have any name and the type condition ("on UserType")
-- | Inline fragments don't have any name and the type condition ("on UserType")
-- is optional.
--
-- @
@ -159,7 +159,7 @@ data InlineFragment = InlineFragment
(Maybe TypeCondition) [Directive] SelectionSet Location
deriving (Eq, Show)
-- A fragment spread refers to a fragment defined outside the operation and is
-- | A fragment spread refers to a fragment defined outside the operation and is
-- expanded at the execution time.
--
-- @
@ -190,7 +190,7 @@ data FragmentSpread = FragmentSpread Name [Directive] Location
-- @
--
-- Here "id" is an argument for the field "user" and its value is 4.
data Argument = Argument Name Value deriving (Eq,Show)
data Argument = Argument Name Value Location deriving (Eq,Show)
-- ** Fragments

2
src/Language/GraphQL/AST/Encoder.hs
View File

@ -159,7 +159,7 @@ arguments :: Formatter -> [Argument] -> Lazy.Text
arguments formatter = parensCommas formatter $ argument formatter
argument :: Formatter -> Argument -> Lazy.Text
argument formatter (Argument name value')
argument formatter (Argument name value' _)
= Lazy.Text.fromStrict name
<> colon formatter
<> value formatter value'

4
src/Language/GraphQL/AST/Lexer.hs
View File

@ -100,8 +100,8 @@ amp :: Parser T.Text
amp = symbol "&"
-- | Parser for ":".
colon :: Parser T.Text
colon = symbol ":"
colon :: Parser ()
colon = symbol ":" >> pure ()
-- | Parser for "=".
equals :: Parser T.Text

7
src/Language/GraphQL/AST/Parser.hs
View File

@ -398,7 +398,12 @@ arguments :: Parser [Argument]
arguments = listOptIn parens argument <?> "Arguments"
argument :: Parser Argument
argument = Argument <$> name <* colon <*> value <?> "Argument"
argument = label "Argument" $ do
location <- getLocation
name' <- name
colon
value' <- value
pure $ Argument name' value' location
fragmentSpread :: Parser FragmentSpread
fragmentSpread = label "FragmentSpread" $ do

4
src/Language/GraphQL/Execute/Transform.hs
View File

@ -304,7 +304,7 @@ field (Full.Field alias name arguments' directives' selections _) = do
let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives
where
go arguments (Full.Argument name' value') =
go arguments (Full.Argument name' value' _) =
inputField arguments name' value'
fragmentSpread
@ -363,7 +363,7 @@ directives = traverse directive
directive (Full.Directive directiveName directiveArguments)
= Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments
go arguments (Full.Argument name value') = do
go arguments (Full.Argument name value' _) = do
substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments

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

@ -12,9 +12,9 @@ module Language.GraphQL.Validate
, module Language.GraphQL.Validate.Rules
) where
import Control.Monad (foldM)
import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
import Data.Foldable (fold, foldrM)
import Control.Monad (join)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (runReaderT)
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document
@ -23,110 +23,79 @@ import Language.GraphQL.Type.Schema (Schema(..))
import Language.GraphQL.Validate.Rules
import Language.GraphQL.Validate.Validation
type ValidateT m = Reader (Validation m) (Seq Error)
-- | 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
document schema' rules' document' =
runReader (foldrM go Seq.empty document') context
runReaderT reader context
where
context = Validation
{ ast = document'
, schema = schema'
, types = collectReferencedTypes schema'
, rules = rules'
}
go definition' accumulator = (accumulator ><) <$> definition definition'
reader = do
rule' <- lift $ Seq.fromList rules'
join $ lift $ foldr (definition rule') Seq.empty document'
definition :: forall m. Definition -> ValidateT m
definition definition'
| ExecutableDefinition executableDefinition' <- definition'
= visitChildSelections ruleFilter
$ executableDefinition executableDefinition'
| otherwise = asks rules >>= foldM ruleFilter Seq.empty
definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m)
definition (DefinitionRule rule) definition' acc =
acc |> rule definition'
definition rule (ExecutableDefinition executableDefinition') acc =
acc >< executableDefinition rule executableDefinition'
definition _ _ acc = acc
executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m)
executableDefinition rule (DefinitionOperation operation) =
operationDefinition rule operation
executableDefinition rule (DefinitionFragment fragment) =
fragmentDefinition rule fragment
operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
operationDefinition (OperationDefinitionRule rule) operationDefinition' =
pure $ rule operationDefinition'
operationDefinition rule (SelectionSet selections _) =
selectionSet rule selections
operationDefinition rule (OperationDefinition _ _ _ _ selections _) =
selectionSet rule selections
fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m)
fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
pure $ rule fragmentDefinition'
fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ _ selections _)
| FragmentRule definitionRule _ <- rule =
applyToChildren |> definitionRule fragmentDefinition'
| otherwise = applyToChildren
where
ruleFilter accumulator (DefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule definition'
ruleFilter accumulator _ = pure accumulator
applyToChildren = selectionSet rule selections
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
runRule accumulator (Just error') = pure $ accumulator |> error'
runRule accumulator Nothing = pure accumulator
selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
selectionSet = foldMap . selection
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
executableDefinition (DefinitionOperation definition') =
operationDefinition definition'
executableDefinition (DefinitionFragment definition') =
fragmentDefinition definition'
operationDefinition :: forall m. OperationDefinition -> ValidateT m
operationDefinition operation =
let selectionSet = getSelectionSet operation
in visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
selection :: Rule m -> Selection -> Seq (RuleT m)
selection rule selection'
| SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule selection'
| otherwise = applyToChildren
where
ruleFilter accumulator (OperationDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule operation
ruleFilter accumulator _ = pure accumulator
getSelectionSet (SelectionSet selectionSet _) = selectionSet
getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
applyToChildren =
case selection' of
FieldSelection field' -> field rule field'
InlineFragmentSelection inlineFragment' ->
inlineFragment rule inlineFragment'
FragmentSpreadSelection fragmentSpread' ->
pure $ fragmentSpread rule fragmentSpread'
visitChildSelections :: forall m
. (Seq Error -> Rule m -> ValidateT m)
-> ValidateT m
-> ValidateT m
visitChildSelections ruleFilter children' = do
rules' <- asks rules
applied <- foldM ruleFilter Seq.empty rules'
children <- children'
pure $ children >< applied
field :: Rule m -> Field -> Seq (RuleT m)
field (FieldRule rule) field' = pure $ rule field'
field rule (Field _ _ _ _ selections _) = selectionSet rule selections
selection :: forall m. Selection -> ValidateT m
selection selection'
| FragmentSpreadSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
| FieldSelection fieldSelection <- selection' =
visitChildSelections ruleFilter $ field fieldSelection
| InlineFragmentSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ inlineFragment fragmentSelection
where
ruleFilter accumulator (SelectionRule rule) =
mapReaderT (runRule accumulator) $ rule selection'
ruleFilter accumulator _ = pure accumulator
inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
inlineFragment (FragmentRule _ rule) inlineFragment' =
pure $ rule inlineFragment'
inlineFragment rule (InlineFragment _ _ selections _) =
selectionSet rule selections
field :: forall m. Field -> ValidateT m
field field'@(Field _ _ _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FieldRule rule) =
mapReaderT (runRule accumulator) $ rule field'
ruleFilter accumulator _ = pure accumulator
inlineFragment :: forall m. InlineFragment -> ValidateT m
inlineFragment fragment@(InlineFragment _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FragmentRule _ inlineRule) =
mapReaderT (runRule accumulator) $ inlineRule fragment
ruleFilter accumulator _ = pure accumulator
fragmentSpread :: forall m. FragmentSpread -> ValidateT m
fragmentSpread fragment =
asks rules >>= foldM ruleFilter Seq.empty
where
ruleFilter accumulator (FragmentSpreadRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator _ = pure accumulator
traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m
traverseSelectionSet = fmap fold . traverse selection
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) =
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
where
ruleFilter accumulator (FragmentDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator (FragmentRule definitionRule _) =
mapReaderT (runRule accumulator) $ definitionRule fragment
ruleFilter accumulator _ = pure accumulator
fragmentSpread :: Rule m -> FragmentSpread -> RuleT m
fragmentSpread (FragmentSpreadRule rule) fragmentSpread' = rule fragmentSpread'
fragmentSpread _ _ = lift mempty

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

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

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

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

8
tests/Language/GraphQL/AST/EncoderSpec.hs
View File

@ -121,11 +121,11 @@ spec = do
describe "definition" $
it "indents block strings in arguments" $
let arguments = [Argument "message" (String "line1\nline2")]
field = Field Nothing "field" arguments [] [] $ Location 0 0
let location = Location 0 0
arguments = [Argument "message" (String "line1\nline2") location]
field = Field Nothing "field" arguments [] [] location
operation = DefinitionOperation
$ SelectionSet (pure $ FieldSelection field)
$ Location 0 0
$ SelectionSet (pure $ FieldSelection field) location
in definition pretty operation `shouldBe` [r|{
field(message: """
line1

2
tests/Language/GraphQL/AST/LexerSpec.hs
View File

@ -75,7 +75,7 @@ spec = describe "Lexer" $ do
parse dollar "" "$" `shouldParse` "$"
runBetween parens `shouldSucceedOn` "()"
parse spread "" "..." `shouldParse` "..."
parse colon "" ":" `shouldParse` ":"
parse colon "" `shouldSucceedOn` ":"
parse equals "" "=" `shouldParse` "="
parse at "" "@" `shouldParse` "@"
runBetween brackets `shouldSucceedOn` "[]"