diff options
Diffstat (limited to 'src/Language/GraphQL/Validate')
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 65 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Validation.hs | 2 |
2 files changed, 54 insertions, 13 deletions
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index a5754c6..11f4482 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -24,6 +24,7 @@ module Language.GraphQL.Validate.Rules , noUndefinedVariablesRule , noUnusedFragmentsRule , noUnusedVariablesRule + , providedRequiredInputFieldsRule , providedRequiredArgumentsRule , scalarLeafsRule , singleFieldSubscriptionsRule @@ -91,6 +92,7 @@ specifiedRules = -- Values , knownInputFieldNamesRule , uniqueInputFieldNamesRule + , providedRequiredInputFieldsRule -- Directives. , knownDirectiveNamesRule , directivesInValidLocationsRule @@ -646,7 +648,7 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas findDirectiveVariables (Directive _ arguments _) = mapArguments arguments mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapDirectives = foldMap findDirectiveVariables - findArgumentVariables (Argument _ Node{ value = Variable value', ..} _) = + findArgumentVariables (Argument _ Node{ node = Variable value', ..} _) = Just (value', [location]) findArgumentVariables _ = Nothing makeError operationName (variableName, locations') = Error @@ -680,12 +682,12 @@ uniqueInputFieldNamesRule :: forall m. Rule m uniqueInputFieldNamesRule = ValueRule (const $ lift . go) (const $ lift . constGo) where - go (Object fields) = filterFieldDuplicates fields + go (Node (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 (Node (ConstObject fields) _) = filterFieldDuplicates fields constGo _ = mempty -- | The target field of a field selection must be defined on the scoped type of @@ -848,11 +850,11 @@ knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do knownInputFieldNamesRule :: Rule m knownInputFieldNamesRule = ValueRule go constGo where - go (Just valueType) (Object inputFields) + go (Just valueType) (Node (Object inputFields) _) | In.InputObjectBaseType objectType <- valueType = lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields go _ _ = lift mempty - constGo (Just valueType) (ConstObject inputFields) + constGo (Just valueType) (Node (ConstObject inputFields) _) | In.InputObjectBaseType objectType <- valueType = lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields constGo _ _ = lift mempty @@ -915,13 +917,6 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule 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' @@ -956,3 +951,49 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule , 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) (Node (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 (ObjectField _ (Node Null _) _)) = True + isNothingOrNull x = isNothing x + lookupField needle (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 32a454e..7ffab10 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -48,7 +48,7 @@ data Rule 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 -> Value -> RuleT m) (Maybe In.Type -> ConstValue -> 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) Seq Error |