diff options
Diffstat (limited to 'src/Language/GraphQL/Validate')
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 938 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Validation.hs | 32 |
2 files changed, 883 insertions, 87 deletions
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 690631e..c67df1c 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -2,160 +2,229 @@ 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/. -} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | This module contains default rules defined in the GraphQL specification. module Language.GraphQL.Validate.Rules - ( executableDefinitionsRule + ( directivesInValidLocationsRule + , executableDefinitionsRule + , fieldsOnCorrectTypeRule + , fragmentsOnCompositeTypesRule + , fragmentSpreadTargetDefinedRule + , fragmentSpreadTypeExistenceRule , loneAnonymousOperationRule + , knownArgumentNamesRule + , knownDirectiveNamesRule + , knownInputFieldNamesRule + , noFragmentCyclesRule + , noUndefinedVariablesRule + , noUnusedFragmentsRule + , noUnusedVariablesRule + , providedRequiredInputFieldsRule + , providedRequiredArgumentsRule + , scalarLeafsRule , singleFieldSubscriptionsRule , specifiedRules + , uniqueArgumentNamesRule + , uniqueDirectiveNamesRule , uniqueFragmentNamesRule + , uniqueInputFieldNamesRule , uniqueOperationNamesRule + , uniqueVariableNamesRule + , variablesAreInputTypesRule ) where -import Control.Monad (foldM) +import Control.Monad ((>=>), foldM) import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Reader (asks) -import Control.Monad.Trans.State (evalStateT, gets, modify) +import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT) +import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) +import Data.Bifunctor (first) +import Data.Foldable (find, toList) +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet +import Data.List (groupBy, sortBy, sortOn) +import Data.Maybe (isNothing, mapMaybe) +import Data.List.NonEmpty (NonEmpty) +import Data.Ord (comparing) +import Data.Sequence (Seq(..), (|>)) +import qualified Data.Sequence as Seq +import Data.Text (Text) import qualified Data.Text as Text -import Language.GraphQL.AST.Document -import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.AST.Document as Full +import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.Internal as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Validation +-- Local help type that contains a hash set to track visited fragments. +type ValidationState m a = + StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a + -- | Default rules given in the specification. specifiedRules :: forall m. [Rule m] specifiedRules = + -- Documents. [ executableDefinitionsRule + -- Operations. , singleFieldSubscriptionsRule , loneAnonymousOperationRule , uniqueOperationNamesRule + -- Fields + , fieldsOnCorrectTypeRule + , scalarLeafsRule + -- Arguments. + , knownArgumentNamesRule + , uniqueArgumentNamesRule + , providedRequiredArgumentsRule + -- Fragments. , uniqueFragmentNamesRule + , fragmentSpreadTypeExistenceRule + , fragmentsOnCompositeTypesRule + , noUnusedFragmentsRule + , fragmentSpreadTargetDefinedRule + , noFragmentCyclesRule + -- Values + , knownInputFieldNamesRule + , uniqueInputFieldNamesRule + , providedRequiredInputFieldsRule + -- Directives. + , knownDirectiveNamesRule + , directivesInValidLocationsRule + , uniqueDirectiveNamesRule + -- Variables. + , uniqueVariableNamesRule + , variablesAreInputTypesRule + , noUndefinedVariablesRule + , noUnusedVariablesRule ] -- | Definition must be OperationDefinition or FragmentDefinition. executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule = DefinitionRule $ \case - ExecutableDefinition _ -> lift Nothing - TypeSystemDefinition _ location -> pure $ error' location - TypeSystemExtension _ location -> pure $ error' location + Full.ExecutableDefinition _ -> lift mempty + Full.TypeSystemDefinition _ location' -> pure $ error' location' + Full.TypeSystemExtension _ location' -> pure $ error' location' where - error' location = Error + error' location' = Error { message = "Definition must be OperationDefinition or FragmentDefinition." - , locations = [location] - , path = [] + , locations = [location'] } -- | Subscription operations must have exactly one root field. singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule = OperationDefinitionRule $ \case - OperationDefinition Subscription name' _ _ rootFields location -> do + Full.OperationDefinition Full.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 - [ "Subscription" + { message = concat + [ "Subscription \"" , Text.unpack name - , "must select only one top level field." + , "\" must select only one top level field." ] - , locations = [location] - , path = [] + , locations = [location'] } | otherwise -> pure $ Error { message = errorMessage - , locations = [location] - , path = [] + , locations = [location'] } - _ -> lift Nothing + _ -> lift mempty 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 + forEach accumulator = \case + Full.FieldSelection fieldSelection -> forField accumulator fieldSelection + Full.FragmentSpreadSelection fragmentSelection -> + forSpread accumulator fragmentSelection + Full.InlineFragmentSelection fragmentSelection -> + forInline accumulator fragmentSelection + forField accumulator (Full.Field alias name _ directives' _ _) + | any skip directives' = pure accumulator | Just aliasedName <- alias = pure $ HashSet.insert aliasedName accumulator | otherwise = pure $ HashSet.insert name accumulator - forEach accumulator (FragmentSpread fragmentName directives) - | any skip directives = pure accumulator + forSpread accumulator (Full.FragmentSpread fragmentName directives' _) + | any skip directives' = pure accumulator | otherwise = do inVisitetFragments <- gets $ HashSet.member fragmentName if inVisitetFragments then pure accumulator else collectFromSpread fragmentName accumulator - forEach accumulator (InlineFragment typeCondition' directives selectionSet) - | any skip directives = pure accumulator - | Just typeCondition <- typeCondition' = - collectFromFragment typeCondition selectionSet accumulator + forInline accumulator (Full.InlineFragment maybeType directives' selections _) + | any skip directives' = pure accumulator + | Just typeCondition <- maybeType = + collectFromFragment typeCondition selections accumulator | otherwise = HashSet.union accumulator - <$> collectFields selectionSet - skip (Directive "skip" [Argument "if" (Boolean True)]) = True - skip (Directive "include" [Argument "if" (Boolean False)]) = True + <$> collectFields selections + skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) = + Full.Boolean True == argumentValue + skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) = + Full.Boolean False == argumentValue skip _ = False - findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing - | DefinitionFragment fragmentDefinition <- executableDefinition = - Just fragmentDefinition - findFragmentDefinition _ accumulator = accumulator collectFromFragment typeCondition selectionSet accumulator = do - types' <- lift $ asks types + types' <- lift $ asks $ Schema.types . schema schema' <- lift $ asks schema - case lookupTypeCondition typeCondition types' of + case Type.lookupTypeCondition typeCondition types' of Nothing -> pure accumulator Just compositeType | Just objectType <- Schema.subscription schema' - , True <- doesFragmentTypeApply compositeType objectType -> - HashSet.union accumulator<$> collectFields selectionSet + , True <- Type.doesFragmentTypeApply compositeType objectType -> + HashSet.union accumulator <$> collectFields selectionSet | otherwise -> pure accumulator collectFromSpread fragmentName accumulator = do modify $ HashSet.insert fragmentName ast' <- lift $ asks ast - case foldr findFragmentDefinition Nothing ast' of + case findFragmentDefinition fragmentName ast' of Nothing -> pure accumulator - Just (FragmentDefinition _ typeCondition _ selectionSet _) -> + Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) -> collectFromFragment typeCondition selectionSet accumulator -- | GraphQL allows a short‐hand form for defining query operations when only -- that one operation exists in the document. loneAnonymousOperationRule :: forall m. Rule m loneAnonymousOperationRule = OperationDefinitionRule $ \case - SelectionSet _ thisLocation -> check thisLocation - OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation - _ -> lift Nothing + Full.SelectionSet _ thisLocation -> check thisLocation + Full.OperationDefinition _ Nothing _ _ _ thisLocation -> + check thisLocation + _ -> 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 compareAnonymousOperations thisLocation = \case - OperationDefinition _ _ _ _ _ thatLocation + Full.OperationDefinition _ _ _ _ _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation - SelectionSet _ thatLocation + Full.SelectionSet _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation - _ -> Nothing - error' location = Error + _ -> mempty + error' location' = Error { message = "This anonymous operation must be the only defined operation." - , locations = [location] - , path = [] + , locations = [location'] } -- | 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 -> + Full.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 \"" @@ -164,12 +233,12 @@ uniqueOperationNamesRule = OperationDefinitionRule $ \case ] filterByName thisName definition' accumulator | (viewOperation -> Just operationDefinition) <- definition' - , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition + , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator -findDuplicates :: (Definition -> [Location] -> [Location]) - -> Location +findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location]) + -> Full.Location -> String -> RuleT m findDuplicates filterByName thisLocation errorMessage = do @@ -177,21 +246,27 @@ 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 , locations = locations' - , path = [] } -viewOperation :: Definition -> Maybe OperationDefinition +viewOperation :: Full.Definition -> Maybe Full.OperationDefinition viewOperation definition - | ExecutableDefinition executableDefinition <- definition - , DefinitionOperation operationDefinition <- executableDefinition = + | Full.ExecutableDefinition executableDefinition <- definition + , Full.DefinitionOperation operationDefinition <- executableDefinition = Just operationDefinition viewOperation _ = Nothing +viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition +viewFragment definition + | Full.ExecutableDefinition executableDefinition <- definition + , Full.DefinitionFragment fragmentDefinition <- executableDefinition = + Just fragmentDefinition +viewFragment _ = Nothing + -- | Fragment definitions are referenced in fragment spreads by name. To avoid -- ambiguity, each fragment’s name must be unique within a document. -- @@ -199,7 +274,7 @@ viewOperation _ = Nothing -- by this validation rule. uniqueFragmentNamesRule :: forall m. Rule m uniqueFragmentNamesRule = FragmentDefinitionRule $ \case - FragmentDefinition thisName _ _ _ thisLocation -> + Full.FragmentDefinition thisName _ _ _ thisLocation -> findDuplicates (filterByName thisName) thisLocation (error' thisName) where error' fragmentName = concat @@ -208,8 +283,733 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case , "\"." ] filterByName thisName definition accumulator - | ExecutableDefinition executableDefinition <- definition - , DefinitionFragment fragmentDefinition <- executableDefinition - , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition + | Just fragmentDefinition <- viewFragment definition + , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator + +-- | Named fragment spreads must refer to fragments defined within the document. +-- It is a validation error if the target of a spread is not defined. +fragmentSpreadTargetDefinedRule :: forall m. Rule m +fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case + Full.FragmentSpread fragmentName _ location' -> do + ast' <- asks ast + case find (isSpreadTarget fragmentName) ast' of + Nothing -> pure $ Error + { message = error' fragmentName + , locations = [location'] + } + Just _ -> lift mempty + where + error' fragmentName = concat + [ "Fragment target \"" + , Text.unpack fragmentName + , "\" is undefined." + ] + +isSpreadTarget :: Text -> Full.Definition -> Bool +isSpreadTarget thisName (viewFragment -> Just fragmentDefinition) + | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition + , thisName == thatName = True +isSpreadTarget _ _ = False + +-- | Fragments must be specified on types that exist in the schema. This applies +-- for both named and inline fragments. If they are not defined in the schema, +-- the query does not validate. +fragmentSpreadTypeExistenceRule :: forall m. Rule m +fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case + Full.FragmentSpreadSelection fragmentSelection + | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do + ast' <- asks ast + let target = find (isSpreadTarget fragmentName) ast' + typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition + types' <- asks $ Schema.types . schema + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = spreadError fragmentName typeCondition + , locations = [location'] + } + Just _ -> lift mempty + Full.InlineFragmentSelection fragmentSelection + | Full.InlineFragment maybeType _ _ location' <- fragmentSelection + , Just typeCondition <- maybeType -> do + types' <- asks $ Schema.types . schema + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = inlineError typeCondition + , locations = [location'] + } + Just _ -> lift mempty + _ -> lift mempty + where + extractTypeCondition (viewFragment -> Just fragmentDefinition) = + let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition + in Just typeCondition + extractTypeCondition _ = Nothing + spreadError fragmentName typeCondition = concat + [ "Fragment \"" + , Text.unpack fragmentName + , "\" is specified on type \"" + , Text.unpack typeCondition + , "\" which doesn't exist in the schema." + ] + inlineError typeCondition = concat + [ "Inline fragment is specified on type \"" + , Text.unpack typeCondition + , "\" 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. +fragmentsOnCompositeTypesRule :: forall m. Rule m +fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule + where + inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') = + check typeCondition location' + inlineRule _ = lift mempty + definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') = + check typeCondition location' + check typeCondition location' = do + types' <- asks $ Schema.types . schema + -- Skip unknown types, they are checked by another rule. + _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types' + case Type.lookupTypeCondition typeCondition types' of + Nothing -> pure $ Error + { message = errorMessage typeCondition + , locations = [location'] + } + Just _ -> lift mempty + errorMessage typeCondition = concat + [ "Fragment cannot condition on non composite type \"" + , Text.unpack typeCondition, + "\"." + ] + +-- | Defined fragments must be used within a document. +noUnusedFragmentsRule :: forall m. Rule m +noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do + let Full.FragmentDefinition fragmentName _ _ _ location' = fragment + in mapReaderT (checkFragmentName fragmentName location') + $ asks ast + >>= flip evalStateT HashSet.empty + . filterSelections evaluateSelection + . foldMap definitionSelections + where + checkFragmentName fragmentName location' elements + | fragmentName `elem` elements = mempty + | otherwise = pure $ makeError fragmentName location' + makeError fragName location' = Error + { message = errorMessage fragName + , locations = [location'] + } + errorMessage fragName = concat + [ "Fragment \"" + , Text.unpack fragName + , "\" is never used." + ] + evaluateSelection selection + | Full.FragmentSpreadSelection spreadSelection <- selection + , Full.FragmentSpread spreadName _ _ <- spreadSelection = + lift $ pure spreadName + evaluateSelection _ = lift $ lift mempty + +definitionSelections :: Full.Definition -> Full.SelectionSetOpt +definitionSelections (viewOperation -> Just operation) + | Full.OperationDefinition _ _ _ _ selections _ <- operation = + toList selections + | Full.SelectionSet selections _ <- operation = toList selections +definitionSelections (viewFragment -> Just fragment) + | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections +definitionSelections _ = [] + +filterSelections :: Foldable t + => forall a m + . (Full.Selection -> ValidationState m a) + -> t Full.Selection + -> ValidationState m a +filterSelections applyFilter selections + = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections) + >>= applyFilter + where + evaluateSelection selection accumulator + | Full.FragmentSpreadSelection{} <- selection = selection : accumulator + | Full.FieldSelection fieldSelection <- selection + , Full.Field _ _ _ _ subselections _ <- fieldSelection = + selection : foldr evaluateSelection accumulator subselections + | Full.InlineFragmentSelection inlineSelection <- selection + , Full.InlineFragment _ _ subselections _ <- inlineSelection = + selection : foldr evaluateSelection accumulator subselections + +-- | The graph of fragment spreads must not form any cycles including spreading +-- itself. Otherwise an operation could infinitely spread or infinitely execute +-- on cycles in the underlying data. +noFragmentCyclesRule :: forall m. Rule m +noFragmentCyclesRule = FragmentDefinitionRule $ \case + Full.FragmentDefinition fragmentName _ _ selections location' -> do + state <- evalStateT (collectFields selections) + (0, fragmentName) + let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) + case reverse spreadPath of + x : _ | x == fragmentName -> pure $ Error + { message = concat + [ "Cannot spread fragment \"" + , Text.unpack fragmentName + , "\" within itself (via " + , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath + , ")." + ] + , locations = [location'] + } + _ -> lift mempty + where + collectFields :: Traversable t + => t Full.Selection + -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int) + collectFields selectionSet = foldM forEach HashMap.empty selectionSet + forEach accumulator = \case + Full.FieldSelection fieldSelection -> forField accumulator fieldSelection + Full.InlineFragmentSelection fragmentSelection -> + forInline accumulator fragmentSelection + Full.FragmentSpreadSelection fragmentSelection -> + forSpread accumulator fragmentSelection + forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do + firstFragmentName <- gets snd + modify $ first (+ 1) + lastIndex <- gets fst + let newAccumulator = HashMap.insert fragmentName lastIndex accumulator + let inVisitetFragment = HashMap.member fragmentName accumulator + if fragmentName == firstFragmentName || inVisitetFragment + then pure newAccumulator + else collectFromSpread fragmentName newAccumulator + forInline accumulator (Full.InlineFragment _ _ selections _) = + (accumulator <>) <$> collectFields selections + forField accumulator (Full.Field _ _ _ _ selections _) = + (accumulator <>) <$> collectFields selections + collectFromSpread fragmentName accumulator = do + ast' <- lift $ asks ast + case findFragmentDefinition fragmentName ast' of + Nothing -> pure accumulator + Just (Full.FragmentDefinition _ _ _ selections _) -> + (accumulator <>) <$> collectFields selections + +findFragmentDefinition :: Text + -> NonEmpty Full.Definition + -> Maybe Full.FragmentDefinition +findFragmentDefinition fragmentName = foldr compareDefinition Nothing + where + compareDefinition (Full.ExecutableDefinition executableDefinition) Nothing + | Full.DefinitionFragment fragmentDefinition <- executableDefinition + , Full.FragmentDefinition anotherName _ _ _ _ <- fragmentDefinition + , anotherName == fragmentName = Just fragmentDefinition + compareDefinition _ accumulator = accumulator + +-- | Fields and directives treat arguments as a mapping of argument name to +-- value. More than one argument with the same name in an argument set is +-- ambiguous and invalid. +uniqueArgumentNamesRule :: forall m. Rule m +uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule + where + fieldRule _ (Full.Field _ _ arguments _ _ _) = + lift $ filterDuplicates extract "argument" arguments + directiveRule (Full.Directive _ arguments _) = + lift $ filterDuplicates extract "argument" arguments + extract (Full.Argument argumentName _ location') = (argumentName, location') + +-- | Directives are used to describe some metadata or behavioral change on the +-- definition they apply to. When more than one directive of the same name is +-- used, the expected metadata or behavior becomes ambiguous, therefore only one +-- of each directive is allowed per location. +uniqueDirectiveNamesRule :: forall m. Rule m +uniqueDirectiveNamesRule = DirectivesRule + $ const $ lift . filterDuplicates extract "directive" + where + extract (Full.Directive directiveName _ location') = + (directiveName, location') + +filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error +filterDuplicates extract nodeType = Seq.fromList + . fmap makeError + . filter ((> 1) . length) + . groupBy equalByName + . sortOn getName + where + getName = fst . extract + equalByName lhs rhs = getName lhs == getName rhs + makeError directives' = Error + { message = makeMessage $ head directives' + , locations = snd . extract <$> directives' + } + makeMessage directive = concat + [ "There can be only one " + , nodeType + , " named \"" + , Text.unpack $ fst $ extract directive + , "\"." + ] + +-- | If any operation defines more than one variable with the same name, it is +-- ambiguous and invalid. It is invalid even if the type of the duplicate +-- variable is the same. +uniqueVariableNamesRule :: forall m. Rule m +uniqueVariableNamesRule = VariablesRule + $ lift . filterDuplicates extract "variable" + where + extract (Full.VariableDefinition variableName _ _ location') = + (variableName, location') + +-- | Variables can only be input types. Objects, unions and interfaces cannot be +-- used as inputs. +variablesAreInputTypesRule :: forall m. Rule m +variablesAreInputTypesRule = VariablesRule + $ (traverse check . Seq.fromList) >=> lift + where + check (Full.VariableDefinition name typeName _ location') + = asks (Schema.types . schema) + >>= lift + . maybe (makeError name typeName location') (const mempty) + . Type.lookupInputType typeName + makeError name typeName location' = pure $ Error + { message = concat + [ "Variable \"$" + , Text.unpack name + , "\" cannot be non-input type \"" + , Text.unpack $ getTypeName typeName + , "\"." + ] + , locations = [location'] + } + getTypeName (Full.TypeNamed name) = name + getTypeName (Full.TypeList name) = getTypeName name + getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull + getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) = + getTypeName nonNull + +-- | Variables are scoped on a per‐operation 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 = + variableUsageDifference (flip HashMap.difference) errorMessage + where + 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 + , "\"." + ] + +type UsageDifference + = HashMap Full.Name [Full.Location] + -> HashMap Full.Name [Full.Location] + -> HashMap Full.Name [Full.Location] + +variableUsageDifference :: forall m. UsageDifference + -> (Maybe Full.Name -> Full.Name -> String) + -> Rule m +variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case + Full.SelectionSet _ _ -> lift mempty + Full.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 + . difference variableNames' + . HashMap.fromListWith (++) + . toList + getVariableName (Full.VariableDefinition variableName _ _ location') = + (variableName, [location']) + filterSelections' :: Foldable t + => t Full.Selection + -> ValidationState m (Full.Name, [Full.Location]) + filterSelections' = filterSelections variableFilter + variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location]) + variableFilter (Full.InlineFragmentSelection inline) + | Full.InlineFragment _ directives' _ _ <- inline = + lift $ lift $ mapDirectives directives' + variableFilter (Full.FieldSelection fieldSelection) + | Full.Field _ _ arguments directives' _ _ <- fieldSelection = + lift $ lift $ mapArguments arguments <> mapDirectives directives' + variableFilter (Full.FragmentSpreadSelection spread) + | Full.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 (Full.FragmentDefinition _ _ directives' selections _) + = filterSelections' selections + >>= lift . mapReaderT (<> mapDirectives directives') . pure + findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments + mapArguments = Seq.fromList . mapMaybe findArgumentVariables + mapDirectives = foldMap findDirectiveVariables + findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) = + Just (value', [location]) + findArgumentVariables _ = Nothing + makeError operationName (variableName, locations') = Error + { message = errorMessage operationName variableName + , locations = locations' + } + +-- | All variables defined by an operation must be used in that operation or a +-- fragment transitively included by that operation. Unused variables cause a +-- validation error. +noUnusedVariablesRule :: forall m. Rule m +noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage + where + errorMessage Nothing variableName = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" is never used." + ] + errorMessage (Just operationName) variableName = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" is never used in operation \"" + , Text.unpack operationName + , "\"." + ] + +-- | Input objects must not contain more than one field of the same name, +-- otherwise an ambiguity would exist which includes an ignored portion of +-- syntax. +uniqueInputFieldNamesRule :: forall m. Rule m +uniqueInputFieldNamesRule = + ValueRule (const $ lift . go) (const $ lift . constGo) + where + go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields + go _ = mempty + filterFieldDuplicates fields = + filterDuplicates getFieldName "input field" fields + getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location') + constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields + constGo _ = mempty + +-- | The target field of a field selection must be defined on the scoped type of +-- the selection set. There are no limitations on alias names. +fieldsOnCorrectTypeRule :: forall m. Rule m +fieldsOnCorrectTypeRule = FieldRule fieldRule + where + fieldRule parentType (Full.Field _ fieldName _ _ _ location') + | Just objectType <- parentType + , Nothing <- Type.lookupTypeField fieldName objectType + , Just typeName <- compositeTypeName objectType = pure $ Error + { message = errorMessage fieldName typeName + , locations = [location'] + } + | otherwise = lift mempty + errorMessage fieldName typeName = concat + [ "Cannot query field \"" + , Text.unpack fieldName + , "\" on type \"" + , Text.unpack typeName + , "\"." + ] + +compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name +compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = + Just typeName +compositeTypeName (Out.InterfaceBaseType interfaceType) = + let Out.InterfaceType typeName _ _ _ = interfaceType + in Just typeName +compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) = + Just typeName +compositeTypeName (Out.ScalarBaseType _) = + Nothing +compositeTypeName (Out.EnumBaseType _) = + Nothing +compositeTypeName (Out.ListBaseType wrappedType) = + compositeTypeName wrappedType + +-- | Field selections on scalars or enums are never allowed, because they are +-- the leaf nodes of any GraphQL query. +scalarLeafsRule :: forall m. Rule m +scalarLeafsRule = FieldRule fieldRule + where + fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _) + | Just objectType <- parentType + , Just field <- Type.lookupTypeField fieldName objectType = + let Out.Field _ fieldType _ = field + in lift $ check fieldType selectionField + | otherwise = lift mempty + check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = + checkNotEmpty typeName + check (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) = + checkNotEmpty typeName + check (Out.UnionBaseType (Out.UnionType typeName _ _)) = + checkNotEmpty typeName + check (Out.ScalarBaseType (Definition.ScalarType typeName _)) = + checkEmpty typeName + check (Out.EnumBaseType (Definition.EnumType typeName _ _)) = + checkEmpty typeName + check (Out.ListBaseType wrappedType) = check wrappedType + checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') = + let fieldName' = Text.unpack fieldName + in makeError location' $ concat + [ "Field \"" + , fieldName' + , "\" of type \"" + , Text.unpack typeName + , "\" must have a selection of subfields. Did you mean \"" + , fieldName' + , " { ... }\"?" + ] + checkNotEmpty _ _ = mempty + checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty + checkEmpty typeName field' = + let Full.Field _ fieldName _ _ _ location' = field' + in makeError location' $ concat + [ "Field \"" + , Text.unpack fieldName + , "\" must not have a selection since type \"" + , Text.unpack typeName + , "\" has no subfields." + ] + makeError location' errorMessage = pure $ Error + { message = errorMessage + , locations = [location'] + } + +-- | Every argument provided to a field or directive must be defined in the set +-- of possible arguments of that field or directive. +knownArgumentNamesRule :: forall m. Rule m +knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule + where + fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _) + | Just typeField <- Type.lookupTypeField fieldName objectType + , Just typeName <- compositeTypeName objectType = + lift $ foldr (go typeName fieldName typeField) Seq.empty arguments + fieldRule _ _ = lift mempty + go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors + | Out.Field _ _ definitions <- fieldDefinition + , Just _ <- HashMap.lookup argumentName definitions = errors + | otherwise = errors |> Error + { message = fieldMessage argumentName fieldName typeName + , locations = [location'] + } + fieldMessage argumentName fieldName typeName = concat + [ "Unknown argument \"" + , Text.unpack argumentName + , "\" on field \"" + , Text.unpack typeName + , "." + , Text.unpack fieldName + , "\"." + ] + directiveRule (Full.Directive directiveName arguments _) = do + available <- asks $ HashMap.lookup directiveName + . Schema.directives . schema + Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments + case available of + Just (Schema.Directive _ _ definitions) + | not $ HashMap.member argumentName definitions -> + pure $ makeError argumentName directiveName location' + _ -> lift mempty + makeError argumentName directiveName location' = Error + { message = directiveMessage argumentName directiveName + , locations = [location'] + } + directiveMessage argumentName directiveName = concat + [ "Unknown argument \"" + , Text.unpack argumentName + , "\" on directive \"@" + , Text.unpack directiveName + , "\"." + ] + +-- | GraphQL servers define what directives they support. For each usage of a +-- directive, the directive must be available on that server. +knownDirectiveNamesRule :: Rule m +knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do + definitions' <- asks $ Schema.directives . schema + let directiveSet = HashSet.fromList $ fmap directiveName directives' + let definitionSet = HashSet.fromList $ HashMap.keys definitions' + let difference = HashSet.difference directiveSet definitionSet + let undefined' = filter (definitionFilter difference) directives' + lift $ Seq.fromList $ makeError <$> undefined' + where + definitionFilter difference = flip HashSet.member difference + . directiveName + directiveName (Full.Directive directiveName' _ _) = directiveName' + makeError (Full.Directive directiveName' _ location') = Error + { message = errorMessage directiveName' + , locations = [location'] + } + errorMessage directiveName' = concat + [ "Unknown directive \"@" + , Text.unpack directiveName' + , "\"." + ] + +-- | Every input field provided in an input object value must be defined in the +-- set of possible fields of that input object’s expected type. +knownInputFieldNamesRule :: Rule m +knownInputFieldNamesRule = ValueRule go constGo + where + go (Just valueType) (Full.Node (Full.Object inputFields) _) + | In.InputObjectBaseType objectType <- valueType = + lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields + go _ _ = lift mempty + constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _) + | In.InputObjectBaseType objectType <- valueType = + lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields + constGo _ _ = lift mempty + forEach objectType (Full.ObjectField inputFieldName _ location') + | In.InputObjectType _ _ fieldTypes <- objectType + , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing + | otherwise + , In.InputObjectType typeName _ _ <- objectType = pure $ Error + { message = errorMessage inputFieldName typeName + , locations = [location'] + } + errorMessage fieldName typeName = concat + [ "Field \"" + , Text.unpack fieldName + , "\" is not defined by type \"" + , Text.unpack typeName + , "\"." + ] + +-- | GraphQL servers define what directives they support and where they support +-- them. For each usage of a directive, the directive must be used in a location +-- that the server has declared support for. +directivesInValidLocationsRule :: Rule m +directivesInValidLocationsRule = DirectivesRule directivesRule + where + directivesRule directiveLocation directives' = do + Full.Directive directiveName _ location <- lift $ Seq.fromList directives' + maybeDefinition <- asks + $ HashMap.lookup directiveName . Schema.directives . schema + case maybeDefinition of + Just (Schema.Directive _ allowedLocations _) + | directiveLocation `notElem` allowedLocations -> pure $ Error + { message = errorMessage directiveName directiveLocation + , locations = [location] + } + _ -> lift mempty + errorMessage directiveName directiveLocation = concat + [ "Directive \"@" + , Text.unpack directiveName + , "\" may not be used on " + , show directiveLocation + , "." + ] + +-- | Arguments can be required. An argument is required if the argument type is +-- non‐null and does not have a default value. Otherwise, the argument is +-- optional. +providedRequiredArgumentsRule :: Rule m +providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule + where + fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ location') + | Just typeField <- Type.lookupTypeField fieldName objectType + , Out.Field _ _ definitions <- typeField = + let forEach = go (fieldMessage fieldName) arguments location' + in lift $ HashMap.foldrWithKey forEach Seq.empty definitions + fieldRule _ _ = lift mempty + directiveRule (Full.Directive directiveName arguments location') = do + available <- asks + $ HashMap.lookup directiveName . Schema.directives . schema + case available of + Just (Schema.Directive _ _ definitions) -> + let forEach = go (directiveMessage directiveName) arguments location' + in lift $ HashMap.foldrWithKey forEach Seq.empty definitions + _ -> lift mempty + go makeMessage arguments location' argumentName argumentType errors + | In.Argument _ type' optionalValue <- argumentType + , In.isNonNullType type' + , typeName <- inputTypeName type' + , isNothing optionalValue + , isNothingOrNull $ find (lookupArgument argumentName) arguments + = errors + |> makeError (makeMessage argumentName typeName) location' + | otherwise = errors + makeError errorMessage location' = Error + { message = errorMessage + , locations = [location'] + } + isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True + isNothingOrNull x = isNothing x + lookupArgument needle (Full.Argument argumentName _ _) = + needle == argumentName + fieldMessage fieldName argumentName typeName = concat + [ "Field \"" + , Text.unpack fieldName + , "\" argument \"" + , Text.unpack argumentName + , "\" of type \"" + , Text.unpack typeName + , "\" is required, but it was not provided." + ] + directiveMessage directiveName argumentName typeName = concat + [ "Directive \"@" + , Text.unpack directiveName + , "\" argument \"" + , Text.unpack argumentName + , "\" of type \"" + , Text.unpack typeName + , "\" is required, but it was not provided." + ] + +inputTypeName :: In.Type -> Text +inputTypeName (In.ScalarBaseType (Definition.ScalarType typeName _)) = typeName +inputTypeName (In.EnumBaseType (Definition.EnumType typeName _ _)) = typeName +inputTypeName (In.InputObjectBaseType (In.InputObjectType typeName _ _)) = + typeName +inputTypeName (In.ListBaseType listType) = inputTypeName listType + +-- | Input object fields may be required. Much like a field may have required +-- arguments, an input object may have required fields. An input field is +-- required if it has a non‐null type and does not have a default value. +-- Otherwise, the input object field is optional. +providedRequiredInputFieldsRule :: Rule m +providedRequiredInputFieldsRule = ValueRule go constGo + where + go (Just valueType) (Full.Node (Full.Object inputFields) location') + | In.InputObjectBaseType objectType <- valueType + , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType + = lift + $ Seq.fromList + $ HashMap.elems + $ flip HashMap.mapMaybeWithKey fieldDefinitions + $ forEach inputFields objectTypeName location' + go _ _ = lift mempty + constGo _ _ = lift mempty + forEach inputFields typeName location' definitionName fieldDefinition + | In.InputField _ inputType optionalValue <- fieldDefinition + , In.isNonNullType inputType + , isNothing optionalValue + , isNothingOrNull $ find (lookupField definitionName) inputFields = + Just $ makeError definitionName typeName location' + | otherwise = Nothing + isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True + isNothingOrNull x = isNothing x + lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName + makeError fieldName typeName location' = Error + { message = errorMessage fieldName typeName + , locations = [location'] + } + errorMessage fieldName typeName = concat + [ "Input field \"" + , Text.unpack fieldName + , "\" of type \"" + , Text.unpack typeName + , "\" is required, but it was not provided." + ] diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 03bbf33..0432a1a 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -5,41 +5,29 @@ -- | Definitions used by the validation rules and the validator itself. module Language.GraphQL.Validate.Validation ( Error(..) - , Path(..) , Rule(..) , RuleT , Validation(..) ) where -import Control.Monad.Trans.Reader (ReaderT(..)) -import Data.HashMap.Strict (HashMap) -import Data.Text (Text) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Sequence (Seq) +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import Language.GraphQL.AST.Document +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out 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 , 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 @@ -49,6 +37,14 @@ data Rule m = DefinitionRule (Definition -> RuleT m) | OperationDefinitionRule (OperationDefinition -> RuleT m) | FragmentDefinitionRule (FragmentDefinition -> RuleT m) + | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m) + | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m) + | FragmentSpreadRule (FragmentSpread -> RuleT m) + | FieldRule (Maybe (Out.Type m) -> Field -> RuleT m) + | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m) + | DirectivesRule (DirectiveLocation -> [Directive] -> RuleT m) + | VariablesRule ([VariableDefinition] -> RuleT m) + | ValueRule (Maybe In.Type -> Node Value -> RuleT m) (Maybe In.Type -> Node ConstValue -> RuleT m) -- | Monad transformer used by the rules. -type RuleT m = ReaderT (Validation m) Maybe Error +type RuleT m = ReaderT (Validation m) Seq Error |