Validate all variables are defined

This commit is contained in:
Eugen Wissner 2020-09-21 07:28:40 +02:00
parent 38c3097bcf
commit 3e393004ae
8 changed files with 166 additions and 43 deletions

View File

@ -11,6 +11,7 @@ and this project adheres to
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread` - `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
and `InlineFragment`. Thus validation rules can be defined more concise. and `InlineFragment`. Thus validation rules can be defined more concise.
- `AST.Document`: `Argument` and `Directive` contain token location. - `AST.Document`: `Argument` and `Directive` contain token location.
- `AST.Document.Argument` contains the `Value` wrapped in the `Node`.
- `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the - `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the
- same). - same).
- `Validate.Validation`: `Validation.rules` was removed. `Validation.rules` - `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`
@ -32,7 +33,6 @@ and this project adheres to
- `ArgumentsRule` - `ArgumentsRule`
- `DirectivesRule` - `DirectivesRule`
- `VariablesRule` - `VariablesRule`
- `Validate.Rules`: - `Validate.Rules`:
- `fragmentsOnCompositeTypesRule` - `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTargetDefinedRule`
@ -43,9 +43,12 @@ and this project adheres to
- `uniqueDirectiveNamesRule` - `uniqueDirectiveNamesRule`
- `uniqueVariableNamesRule` - `uniqueVariableNamesRule`
- `variablesAreInputTypesRule` - `variablesAreInputTypesRule`
- `noUndefinedVariablesRule`
- `noUndefinedVariablesRule`
- `AST.Document.Field`. - `AST.Document.Field`.
- `AST.Document.FragmentSpread`. - `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`. - `AST.Document.InlineFragment`.
- `AST.Document.Node`.
### Fixed ### Fixed
- Collecting existing types from the schema considers subscriptions. - Collecting existing types from the schema considers subscriptions.

View File

@ -24,6 +24,7 @@ module Language.GraphQL.AST.Document
, Location(..) , Location(..)
, Name , Name
, NamedType , NamedType
, Node(..)
, NonNullType(..) , NonNullType(..)
, ObjectField(..) , ObjectField(..)
, OperationDefinition(..) , OperationDefinition(..)
@ -70,6 +71,9 @@ instance Ord Location where
| thisLine > thatLine = GT | thisLine > thatLine = GT
| otherwise = compare thisColumn thatColumn | otherwise = compare thisColumn thatColumn
-- | Contains some tree node with a location.
data Node a = Node a Location deriving (Eq, Show)
-- ** Document -- ** Document
-- | GraphQL document. -- | GraphQL document.
@ -190,7 +194,7 @@ data FragmentSpread = FragmentSpread Name [Directive] Location
-- @ -- @
-- --
-- Here "id" is an argument for the field "user" and its value is 4. -- Here "id" is an argument for the field "user" and its value is 4.
data Argument = Argument Name Value Location deriving (Eq,Show) data Argument = Argument Name (Node Value) Location deriving (Eq, Show)
-- ** Fragments -- ** Fragments

View File

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

View File

@ -402,7 +402,7 @@ argument = label "Argument" $ do
location <- getLocation location <- getLocation
name' <- name name' <- name
colon colon
value' <- value value' <- valueNode
pure $ Argument name' value' location pure $ Argument name' value' location
fragmentSpread :: Parser FragmentSpread fragmentSpread :: Parser FragmentSpread
@ -439,6 +439,12 @@ fragmentName = but (symbol "on") *> name <?> "FragmentName"
typeCondition :: Parser TypeCondition typeCondition :: Parser TypeCondition
typeCondition = symbol "on" *> name <?> "TypeCondition" typeCondition = symbol "on" *> name <?> "TypeCondition"
valueNode :: Parser (Node Value)
valueNode = do
location <- getLocation
value' <- value
pure $ Node value' location
value :: Parser Value value :: Parser Value
value = Variable <$> variable value = Variable <$> variable
<|> Float <$> try float <|> Float <$> try float

View File

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

View File

@ -2,9 +2,9 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
-- | This module contains default rules defined in the GraphQL specification. -- | This module contains default rules defined in the GraphQL specification.
@ -15,6 +15,7 @@ module Language.GraphQL.Validate.Rules
, fragmentSpreadTypeExistenceRule , fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, noFragmentCyclesRule , noFragmentCyclesRule
, noUndefinedVariablesRule
, noUnusedFragmentsRule , noUnusedFragmentsRule
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, specifiedRules , specifiedRules
@ -28,14 +29,16 @@ module Language.GraphQL.Validate.Rules
import Control.Monad ((>=>), foldM) import Control.Monad ((>=>), foldM)
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT, asks) import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.Foldable (find) import Data.Foldable (find, toList)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn) import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (mapMaybe)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Sequence (Seq(..)) import Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -46,6 +49,9 @@ import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation import Language.GraphQL.Validate.Validation
-- Local help type that contains a hash set to track visited fragments.
type ValidationState m a = StateT (HashSet Name) (ReaderT (Validation m) Seq) a
-- | Default rules given in the specification. -- | Default rules given in the specification.
specifiedRules :: forall m. [Rule m] specifiedRules :: forall m. [Rule m]
specifiedRules = specifiedRules =
@ -69,6 +75,7 @@ specifiedRules =
-- Variables. -- Variables.
, uniqueVariableNamesRule , uniqueVariableNamesRule
, variablesAreInputTypesRule , variablesAreInputTypesRule
, noUndefinedVariablesRule
] ]
-- | Definition must be OperationDefinition or FragmentDefinition. -- | Definition must be OperationDefinition or FragmentDefinition.
@ -133,8 +140,10 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
collectFromFragment typeCondition selections accumulator collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator | otherwise = HashSet.union accumulator
<$> collectFields selections <$> collectFields selections
skip (Directive "skip" [Argument "if" (Boolean True) _] _) = True skip (Directive "skip" [Argument "if" (Node argumentValue _) _] _) =
skip (Directive "include" [Argument "if" (Boolean False) _] _) = True Boolean True == argumentValue
skip (Directive "include" [Argument "if" (Node argumentValue _) _] _) =
Boolean False == argumentValue
skip _ = False skip _ = False
findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
| DefinitionFragment fragmentDefinition <- executableDefinition = | DefinitionFragment fragmentDefinition <- executableDefinition =
@ -358,43 +367,57 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
-- | Defined fragments must be used within a document. -- | Defined fragments must be used within a document.
noUnusedFragmentsRule :: forall m. Rule m noUnusedFragmentsRule :: forall m. Rule m
noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
asks ast >>= findSpreadByName fragment let FragmentDefinition fragmentName _ _ _ location = fragment
in mapReaderT (checkFragmentName fragmentName location)
$ asks ast
>>= flip evalStateT HashSet.empty
. filterSelections evaluateSelection
. foldMap definitionSelections
where where
findSpreadByName (FragmentDefinition fragName _ _ _ location) definitions checkFragmentName fragmentName location elements
| foldr (go fragName) False definitions = lift mempty | fragmentName `elem` elements = mempty
| otherwise = pure $ Error | otherwise = pure $ makeError fragmentName location
{ message = errorMessage fragName makeError fragName location = Error
, locations = [location] { message = errorMessage fragName
} , locations = [location]
}
errorMessage fragName = concat errorMessage fragName = concat
[ "Fragment \"" [ "Fragment \""
, Text.unpack fragName , Text.unpack fragName
, "\" is never used." , "\" is never used."
] ]
go fragName (viewOperation -> Just operation) accumulator evaluateSelection selection
| SelectionSet selections _ <- operation =
evaluateSelections fragName accumulator selections
| OperationDefinition _ _ _ _ selections _ <- operation =
evaluateSelections fragName accumulator selections
go fragName (viewFragment -> Just fragment) accumulator
| FragmentDefinition _ _ _ selections _ <- fragment =
evaluateSelections fragName accumulator selections
go _ _ _ = False
evaluateSelection fragName selection accumulator
| FragmentSpreadSelection spreadSelection <- selection | FragmentSpreadSelection spreadSelection <- selection
, FragmentSpread spreadName _ _ <- spreadSelection , FragmentSpread spreadName _ _ <- spreadSelection =
, spreadName == fragName = True lift $ pure spreadName
evaluateSelection _ = lift $ lift mempty
definitionSelections :: Definition -> SelectionSetOpt
definitionSelections (viewOperation -> Just operation)
| OperationDefinition _ _ _ _ selections _ <- operation = toList selections
| SelectionSet selections _ <- operation = toList selections
definitionSelections (viewFragment -> Just fragment)
| FragmentDefinition _ _ _ selections _ <- fragment = toList selections
definitionSelections _ = []
filterSelections :: Foldable t
=> forall a m
. (Selection -> ValidationState m a)
-> t Selection
-> ValidationState m a
filterSelections applyFilter selections
= (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections)
>>= applyFilter
where
evaluateSelection selection accumulator
| FragmentSpreadSelection{} <- selection = selection : accumulator
| FieldSelection fieldSelection <- selection | FieldSelection fieldSelection <- selection
, Field _ _ _ _ selections _ <- fieldSelection = , Field _ _ _ _ subselections _ <- fieldSelection =
evaluateSelections fragName accumulator selections selection : foldr evaluateSelection accumulator subselections
| InlineFragmentSelection inlineSelection <- selection | InlineFragmentSelection inlineSelection <- selection
, InlineFragment _ _ selections _ <- inlineSelection = , InlineFragment _ _ subselections _ <- inlineSelection =
evaluateSelections fragName accumulator selections selection : foldr evaluateSelection accumulator subselections
| otherwise = accumulator || False
evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool
evaluateSelections fragName accumulator selections =
foldr (evaluateSelection fragName) accumulator selections
-- | The graph of fragment spreads must not form any cycles including spreading -- | The graph of fragment spreads must not form any cycles including spreading
-- itself. Otherwise an operation could infinitely spread or infinitely execute -- itself. Otherwise an operation could infinitely spread or infinitely execute
@ -419,8 +442,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
_ -> lift mempty _ -> lift mempty
where where
collectFields :: Traversable t collectFields :: Traversable t
=> forall m => t Selection
. t Selection
-> StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int) -> StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectFields selectionSet = foldM forEach HashMap.empty selectionSet collectFields selectionSet = foldM forEach HashMap.empty selectionSet
forEach accumulator = \case forEach accumulator = \case
@ -434,7 +456,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
modify $ first (+ 1) modify $ first (+ 1)
lastIndex <- gets fst lastIndex <- gets fst
let newAccumulator = HashMap.insert fragmentName lastIndex accumulator let newAccumulator = HashMap.insert fragmentName lastIndex accumulator
let inVisitetFragment =HashMap.member fragmentName accumulator let inVisitetFragment = HashMap.member fragmentName accumulator
if fragmentName == firstFragmentName || inVisitetFragment if fragmentName == firstFragmentName || inVisitetFragment
then pure newAccumulator then pure newAccumulator
else collectFromSpread fragmentName newAccumulator else collectFromSpread fragmentName newAccumulator
@ -533,3 +555,69 @@ variablesAreInputTypesRule = VariablesRule
getTypeName (TypeList name) = getTypeName name getTypeName (TypeList name) = getTypeName name
getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull
getTypeName (TypeNonNull (NonNullTypeList nonNull)) = getTypeName nonNull getTypeName (TypeNonNull (NonNullTypeList nonNull)) = getTypeName nonNull
-- | Variables are scoped on a peroperation basis. That means that any variable
-- used within the context of an operation must be defined at the top level of
-- that operation.
noUndefinedVariablesRule :: forall m. Rule m
noUndefinedVariablesRule = OperationDefinitionRule $ \case
SelectionSet _ _ -> lift mempty
OperationDefinition _ operationName variables _ selections _ ->
let variableNames = HashMap.fromList $ getVariableName <$> variables
in mapReaderT (readerMapper operationName variableNames)
$ flip evalStateT HashSet.empty
$ filterSelections'
$ toList selections
where
readerMapper operationName variableNames' = Seq.fromList
. fmap (makeError operationName)
. HashMap.toList
. flip HashMap.difference variableNames'
. HashMap.fromListWith (++)
. toList
getVariableName (VariableDefinition variableName _ _ _) = (variableName, [])
filterSelections' :: Foldable t
=> t Selection
-> ValidationState m (Name, [Location])
filterSelections' = filterSelections variableFilter
variableFilter :: Selection -> ValidationState m (Name, [Location])
variableFilter (InlineFragmentSelection inline)
| InlineFragment _ directives _ _ <- inline =
lift $ lift $ mapDirectives directives
variableFilter (FieldSelection fieldSelection)
| Field _ _ arguments directives _ _ <- fieldSelection =
lift $ lift $ mapArguments arguments <> mapDirectives directives
variableFilter (FragmentSpreadSelection spread)
| FragmentSpread fragmentName _ _ <- spread = do
definitions <- lift $ asks ast
visited <- gets (HashSet.member fragmentName)
modify (HashSet.insert fragmentName)
case find (isSpreadTarget fragmentName) definitions of
Just (viewFragment -> Just fragmentDefinition)
| not visited -> diveIntoSpread fragmentDefinition
_ -> lift $ lift mempty
diveIntoSpread (FragmentDefinition _ _ directives selections _)
= filterSelections' selections
>>= lift . mapReaderT (<> mapDirectives directives) . pure
findDirectiveVariables (Directive _ arguments _) = mapArguments arguments
mapArguments = Seq.fromList . mapMaybe findArgumentVariables
mapDirectives = foldMap findDirectiveVariables
findArgumentVariables (Argument _ (Node (Variable value) location) _) =
Just (value, [location])
findArgumentVariables _ = Nothing
makeError operationName (variableName, locations') = Error
{ message = errorMessage operationName variableName
, locations = locations'
}
errorMessage Nothing variableName = concat
[ "Variable \"$"
, Text.unpack variableName
, "\" is not defined."
]
errorMessage (Just operationName) variableName = concat
[ "Variable \"$"
, Text.unpack variableName
, "\" is not defined by operation \""
, Text.unpack operationName
, "\"."
]

View File

@ -122,7 +122,8 @@ spec = do
describe "definition" $ describe "definition" $
it "indents block strings in arguments" $ it "indents block strings in arguments" $
let location = Location 0 0 let location = Location 0 0
arguments = [Argument "message" (String "line1\nline2") location] argumentValue = Node (String "line1\nline2") location
arguments = [Argument "message" argumentValue location]
field = Field Nothing "field" arguments [] [] location field = Field Nothing "field" arguments [] [] location
operation = DefinitionOperation operation = DefinitionOperation
$ SelectionSet (pure $ FieldSelection field) location $ SelectionSet (pure $ FieldSelection field) location

View File

@ -471,3 +471,24 @@ spec =
, locations = [AST.Location 2 34] , locations = [AST.Location 2 34]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` Seq.singleton expected
it "rejects undefined variables" $
let queryString = [r|
query variableIsNotDefinedUsedInSingleFragment {
dog {
...isHousetrainedFragment
}
}
fragment isHousetrainedFragment on Dog {
isHousetrained(atOtherHomes: $atOtherHomes)
}
|]
expected = Error
{ message =
"Variable \"$atOtherHomes\" is not defined by \
\operation \
\\"variableIsNotDefinedUsedInSingleFragment\"."
, locations = [AST.Location 9 46]
}
in validate queryString `shouldBe` Seq.singleton expected