959 lines
40 KiB
Haskell
959 lines
40 KiB
Haskell
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
||
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 LambdaCase #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE RecordWildCards #-}
|
||
{-# LANGUAGE ScopedTypeVariables #-}
|
||
{-# LANGUAGE ViewPatterns #-}
|
||
|
||
-- | This module contains default rules defined in the GraphQL specification.
|
||
module Language.GraphQL.Validate.Rules
|
||
( directivesInValidLocationsRule
|
||
, executableDefinitionsRule
|
||
, fieldsOnCorrectTypeRule
|
||
, fragmentsOnCompositeTypesRule
|
||
, fragmentSpreadTargetDefinedRule
|
||
, fragmentSpreadTypeExistenceRule
|
||
, loneAnonymousOperationRule
|
||
, knownArgumentNamesRule
|
||
, knownDirectiveNamesRule
|
||
, knownInputFieldNamesRule
|
||
, noFragmentCyclesRule
|
||
, noUndefinedVariablesRule
|
||
, noUnusedFragmentsRule
|
||
, noUnusedVariablesRule
|
||
, providedRequiredArgumentsRule
|
||
, scalarLeafsRule
|
||
, singleFieldSubscriptionsRule
|
||
, specifiedRules
|
||
, uniqueArgumentNamesRule
|
||
, uniqueDirectiveNamesRule
|
||
, uniqueFragmentNamesRule
|
||
, uniqueInputFieldNamesRule
|
||
, uniqueOperationNamesRule
|
||
, uniqueVariableNamesRule
|
||
, variablesAreInputTypesRule
|
||
) where
|
||
|
||
import Control.Monad ((>=>), foldM)
|
||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||
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.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 qualified Language.GraphQL.Type.Definition as Definition
|
||
import Language.GraphQL.Type.Internal
|
||
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 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
|
||
-- 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 mempty
|
||
TypeSystemDefinition _ location' -> pure $ error' location'
|
||
TypeSystemExtension _ location' -> pure $ error' location'
|
||
where
|
||
error' location' = Error
|
||
{ message =
|
||
"Definition must be OperationDefinition or FragmentDefinition."
|
||
, locations = [location']
|
||
}
|
||
|
||
-- | Subscription operations must have exactly one root field.
|
||
singleFieldSubscriptionsRule :: forall m. Rule m
|
||
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||
OperationDefinition Subscription name' _ _ rootFields location' -> do
|
||
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
|
||
case HashSet.size groupedFieldSet of
|
||
1 -> lift mempty
|
||
_
|
||
| Just name <- name' -> pure $ Error
|
||
{ message = unwords
|
||
[ "Subscription"
|
||
, Text.unpack name
|
||
, "must select only one top level field."
|
||
]
|
||
, locations = [location']
|
||
}
|
||
| otherwise -> pure $ Error
|
||
{ message = errorMessage
|
||
, locations = [location']
|
||
}
|
||
_ -> lift mempty
|
||
where
|
||
errorMessage =
|
||
"Anonymous Subscription must select only one top level field."
|
||
collectFields selectionSet = foldM forEach HashSet.empty selectionSet
|
||
forEach accumulator = \case
|
||
FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||
FragmentSpreadSelection fragmentSelection ->
|
||
forSpread accumulator fragmentSelection
|
||
InlineFragmentSelection fragmentSelection ->
|
||
forInline accumulator fragmentSelection
|
||
forField accumulator (Field alias name _ directives' _ _)
|
||
| any skip directives' = pure accumulator
|
||
| Just aliasedName <- alias = pure
|
||
$ HashSet.insert aliasedName accumulator
|
||
| otherwise = pure $ HashSet.insert name accumulator
|
||
forSpread accumulator (FragmentSpread fragmentName directives' _)
|
||
| any skip directives' = pure accumulator
|
||
| otherwise = do
|
||
inVisitetFragments <- gets $ HashSet.member fragmentName
|
||
if inVisitetFragments
|
||
then pure accumulator
|
||
else collectFromSpread fragmentName accumulator
|
||
forInline accumulator (InlineFragment maybeType directives' selections _)
|
||
| any skip directives' = pure accumulator
|
||
| Just typeCondition <- maybeType =
|
||
collectFromFragment typeCondition selections accumulator
|
||
| otherwise = HashSet.union accumulator
|
||
<$> collectFields selections
|
||
skip (Directive "skip" [Argument "if" (Node argumentValue _) _] _) =
|
||
Boolean True == argumentValue
|
||
skip (Directive "include" [Argument "if" (Node argumentValue _) _] _) =
|
||
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
|
||
schema' <- lift $ asks schema
|
||
case lookupTypeCondition typeCondition types' of
|
||
Nothing -> pure accumulator
|
||
Just compositeType
|
||
| Just objectType <- Schema.subscription schema'
|
||
, True <- 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
|
||
Nothing -> pure accumulator
|
||
Just (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 mempty
|
||
where
|
||
check thisLocation = asks ast
|
||
>>= lift . foldr (filterAnonymousOperations thisLocation) mempty
|
||
filterAnonymousOperations thisLocation definition Empty
|
||
| (viewOperation -> Just operationDefinition) <- definition =
|
||
compareAnonymousOperations thisLocation operationDefinition
|
||
filterAnonymousOperations _ _ accumulator = accumulator
|
||
compareAnonymousOperations thisLocation = \case
|
||
OperationDefinition _ _ _ _ _ thatLocation
|
||
| thisLocation /= thatLocation -> pure $ error' thisLocation
|
||
SelectionSet _ thatLocation
|
||
| thisLocation /= thatLocation -> pure $ error' thisLocation
|
||
_ -> mempty
|
||
error' location' = Error
|
||
{ message =
|
||
"This anonymous operation must be the only defined operation."
|
||
, 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 ->
|
||
findDuplicates (filterByName thisName) thisLocation (error' thisName)
|
||
_ -> lift mempty
|
||
where
|
||
error' operationName = concat
|
||
[ "There can be only one operation named \""
|
||
, Text.unpack operationName
|
||
, "\"."
|
||
]
|
||
filterByName thisName definition' accumulator
|
||
| (viewOperation -> Just operationDefinition) <- definition'
|
||
, OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
|
||
, thisName == thatName = thatLocation : accumulator
|
||
| otherwise = accumulator
|
||
|
||
findDuplicates :: (Definition -> [Location] -> [Location])
|
||
-> Location
|
||
-> String
|
||
-> RuleT m
|
||
findDuplicates filterByName thisLocation errorMessage = do
|
||
ast' <- asks ast
|
||
let locations' = foldr filterByName [] ast'
|
||
if length locations' > 1 && head locations' == thisLocation
|
||
then pure $ error' locations'
|
||
else lift mempty
|
||
where
|
||
error' locations' = Error
|
||
{ message = errorMessage
|
||
, locations = locations'
|
||
}
|
||
|
||
viewOperation :: Definition -> Maybe OperationDefinition
|
||
viewOperation definition
|
||
| ExecutableDefinition executableDefinition <- definition
|
||
, DefinitionOperation operationDefinition <- executableDefinition =
|
||
Just operationDefinition
|
||
viewOperation _ = Nothing
|
||
|
||
viewFragment :: Definition -> Maybe FragmentDefinition
|
||
viewFragment definition
|
||
| ExecutableDefinition executableDefinition <- definition
|
||
, 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.
|
||
--
|
||
-- Inline fragments are not considered fragment definitions, and are unaffected
|
||
-- by this validation rule.
|
||
uniqueFragmentNamesRule :: forall m. Rule m
|
||
uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
|
||
FragmentDefinition thisName _ _ _ thisLocation ->
|
||
findDuplicates (filterByName thisName) thisLocation (error' thisName)
|
||
where
|
||
error' fragmentName = concat
|
||
[ "There can be only one fragment named \""
|
||
, Text.unpack fragmentName
|
||
, "\"."
|
||
]
|
||
filterByName thisName definition accumulator
|
||
| Just fragmentDefinition <- viewFragment definition
|
||
, 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
|
||
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 -> Definition -> Bool
|
||
isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)
|
||
| 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
|
||
FragmentSpreadSelection fragmentSelection
|
||
| FragmentSpread fragmentName _ location' <- fragmentSelection -> do
|
||
ast' <- asks ast
|
||
let target = find (isSpreadTarget fragmentName) ast'
|
||
typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition
|
||
types' <- asks types
|
||
case HashMap.lookup typeCondition types' of
|
||
Nothing -> pure $ Error
|
||
{ message = spreadError fragmentName typeCondition
|
||
, locations = [location']
|
||
}
|
||
Just _ -> lift mempty
|
||
InlineFragmentSelection fragmentSelection
|
||
| InlineFragment maybeType _ _ location' <- fragmentSelection
|
||
, Just typeCondition <- maybeType -> do
|
||
types' <- asks types
|
||
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 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 (InlineFragment (Just typeCondition) _ _ location') =
|
||
check typeCondition location'
|
||
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 $ maybeToSeq $ HashMap.lookup typeCondition types'
|
||
case 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 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
|
||
| FragmentSpreadSelection spreadSelection <- selection
|
||
, FragmentSpread spreadName _ _ <- spreadSelection =
|
||
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
|
||
, Field _ _ _ _ subselections _ <- fieldSelection =
|
||
selection : foldr evaluateSelection accumulator subselections
|
||
| InlineFragmentSelection inlineSelection <- selection
|
||
, 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
|
||
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 Selection
|
||
-> 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
|
||
InlineFragmentSelection fragmentSelection ->
|
||
forInline accumulator fragmentSelection
|
||
FragmentSpreadSelection fragmentSelection ->
|
||
forSpread accumulator fragmentSelection
|
||
forSpread accumulator (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 (InlineFragment _ _ selections _) =
|
||
(accumulator <>) <$> collectFields selections
|
||
forField accumulator (Field _ _ _ _ selections _) =
|
||
(accumulator <>) <$> collectFields selections
|
||
findFragmentDefinition n (ExecutableDefinition executableDefinition) Nothing
|
||
| DefinitionFragment fragmentDefinition <- executableDefinition
|
||
, FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition
|
||
, fragmentName == n = Just fragmentDefinition
|
||
findFragmentDefinition _ _ accumulator = accumulator
|
||
collectFromSpread _fragmentName accumulator = do
|
||
ast' <- lift $ asks ast
|
||
case foldr (findFragmentDefinition _fragmentName) Nothing ast' of
|
||
Nothing -> pure accumulator
|
||
Just (FragmentDefinition _ _ _ selections _) ->
|
||
(accumulator <>) <$> collectFields selections
|
||
|
||
-- | 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 _ (Field _ _ arguments _ _ _) =
|
||
lift $ filterDuplicates extract "argument" arguments
|
||
directiveRule (Directive _ arguments _) =
|
||
lift $ filterDuplicates extract "argument" arguments
|
||
extract (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 (Directive directiveName _ location') = (directiveName, location')
|
||
|
||
filterDuplicates :: (a -> (Text, 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 (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 (VariableDefinition name typeName _ location')
|
||
= asks types
|
||
>>= lift
|
||
. maybe (makeError name typeName location') (const mempty)
|
||
. 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 (TypeNamed name) = name
|
||
getTypeName (TypeList name) = getTypeName name
|
||
getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull
|
||
getTypeName (TypeNonNull (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
|
||
, "\"."
|
||
]
|
||
|
||
variableUsageDifference :: forall m
|
||
. (HashMap Name [Location] -> HashMap Name [Location] -> HashMap Name [Location])
|
||
-> (Maybe Name -> Name -> String)
|
||
-> Rule m
|
||
variableUsageDifference difference errorMessage = 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
|
||
. difference variableNames'
|
||
. HashMap.fromListWith (++)
|
||
. toList
|
||
getVariableName (VariableDefinition variableName _ _ location') =
|
||
(variableName, [location'])
|
||
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{ value = 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 (Object fields) = filterFieldDuplicates fields
|
||
go _ = mempty
|
||
filterFieldDuplicates fields =
|
||
filterDuplicates getFieldName "input field" fields
|
||
getFieldName (ObjectField fieldName _ location') = (fieldName, location')
|
||
constGo (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 (Field _ fieldName _ _ _ location')
|
||
| Just objectType <- parentType
|
||
, Nothing <- 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 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@(Field _ fieldName _ _ _ _)
|
||
| Just objectType <- parentType
|
||
, Just field <- 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 (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 _ (Field _ _ _ _ [] _) = mempty
|
||
checkEmpty typeName field' =
|
||
let 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) (Field _ fieldName arguments _ _ _)
|
||
| Just typeField <- lookupTypeField fieldName objectType
|
||
, Just typeName <- compositeTypeName objectType =
|
||
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
|
||
fieldRule _ _ = lift mempty
|
||
go typeName fieldName fieldDefinition (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 (Directive directiveName arguments _) = do
|
||
available <- asks $ HashMap.lookup directiveName . directives
|
||
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 directives
|
||
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 (Directive directiveName' _ _) = directiveName'
|
||
makeError (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) (Object inputFields)
|
||
| In.InputObjectBaseType objectType <- valueType =
|
||
lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
|
||
go _ _ = lift mempty
|
||
constGo (Just valueType) (ConstObject inputFields)
|
||
| In.InputObjectBaseType objectType <- valueType =
|
||
lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
|
||
constGo _ _ = lift mempty
|
||
forEach objectType (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
|
||
Directive directiveName _ location <- lift $ Seq.fromList directives'
|
||
maybeDefinition <- asks $ HashMap.lookup directiveName . directives
|
||
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) (Field _ fieldName arguments _ _ location')
|
||
| Just typeField <- 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 (Directive directiveName arguments location') = do
|
||
available <- asks $ HashMap.lookup directiveName . directives
|
||
case available of
|
||
Just (Schema.Directive _ _ definitions) ->
|
||
let forEach = go (directiveMessage directiveName) arguments location'
|
||
in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
|
||
_ -> lift mempty
|
||
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
|
||
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 (Argument _ (Node Null _) _)) = True
|
||
isNothingOrNull x = isNothing x
|
||
lookupArgument needle (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."
|
||
]
|