From a034f2ce4d6603b030e653b4a4a2c46098ce8880 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 3 Feb 2021 05:42:10 +0100 Subject: [PATCH] Validate values --- CHANGELOG.md | 1 + src/Language/GraphQL/AST/Document.hs | 3 + src/Language/GraphQL/Validate/Rules.hs | 82 +++++++++++++++++++++++++- tests/Language/GraphQL/ValidateSpec.hs | 36 ++++++++++- 4 files changed, 119 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 817357e..1ba5c58 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,7 @@ and this project adheres to - `overlappingFieldsCanBeMergedRule` - `possibleFragmentSpreadsRule` - `variablesInAllowedPositionRule` + - `valuesOfCorrectTypeRule` - `Type.Schema.implementations` contains a map from interfaces and objects to interfaces they implement. - Show instances for GraphQL type definitions in the `Type` modules. diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index a134f35..a65a01d 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -252,6 +252,9 @@ data ObjectField a = ObjectField , location :: Location } deriving (Eq, Show) +instance Functor ObjectField where + fmap f ObjectField{..} = ObjectField name (f <$> value) location + -- ** Variables -- | Variable definition. diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 3fcfb96..71455d3 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -37,6 +38,7 @@ module Language.GraphQL.Validate.Rules , uniqueInputFieldNamesRule , uniqueOperationNamesRule , uniqueVariableNamesRule + , valuesOfCorrectTypeRule , variablesInAllowedPositionRule , variablesAreInputTypesRule ) where @@ -52,7 +54,7 @@ import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (groupBy, sortBy, sortOn) -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.List.NonEmpty (NonEmpty(..)) import Data.Ord (comparing) import Data.Sequence (Seq(..), (|>)) @@ -97,6 +99,7 @@ specifiedRules = , noFragmentCyclesRule , possibleFragmentSpreadsRule -- Values + , valuesOfCorrectTypeRule , knownInputFieldNamesRule , uniqueInputFieldNamesRule , providedRequiredInputFieldsRule @@ -1523,3 +1526,80 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case ] , locations = [location'] } + +-- | Literal values must be compatible with the type expected in the position +-- they are found as per the coercion rules. +-- +-- The type expected in a position include the type defined by the argument a +-- value is provided for, the type defined by an input object field a value is +-- provided for, and the type of a variable definition a default value is +-- provided for. +valuesOfCorrectTypeRule :: forall m. Rule m +valuesOfCorrectTypeRule = ValueRule go constGo + where + go (Just inputType) value + | Just constValue <- toConstNode value = + lift $ check inputType constValue + go _ _ = lift mempty + toConstNode Full.Node{..} = flip Full.Node location <$> toConst node + toConst (Full.Variable _) = Nothing + toConst (Full.Int integer) = Just $ Full.ConstInt integer + toConst (Full.Float double) = Just $ Full.ConstFloat double + toConst (Full.String string) = Just $ Full.ConstString string + toConst (Full.Boolean boolean) = Just $ Full.ConstBoolean boolean + toConst Full.Null = Just Full.ConstNull + toConst (Full.Enum enum) = Just $ Full.ConstEnum enum + toConst (Full.List values) = + Just $ Full.ConstList $ catMaybes $ toConst <$> values + toConst (Full.Object fields) = Just $ Full.ConstObject + $ catMaybes $ constObjectField <$> fields + constObjectField Full.ObjectField{..} + | Just constValue <- toConstNode value = + Just $ Full.ObjectField name constValue location + | otherwise = Nothing + constGo Nothing = const $ lift mempty + constGo (Just inputType) = lift . check inputType + check :: In.Type -> Full.Node Full.ConstValue -> Seq Error + check _ Full.Node{ node = Full.ConstNull } = + mempty -- Ignore, required fields are checked elsewhere. + check (In.ScalarBaseType scalarType) Full.Node{ node } + | Definition.ScalarType "Int" _ <- scalarType + , Full.ConstInt _ <- node = mempty + | Definition.ScalarType "Boolean" _ <- scalarType + , Full.ConstBoolean _ <- node = mempty + | Definition.ScalarType "String" _ <- scalarType + , Full.ConstString _ <- node = mempty + | Definition.ScalarType "ID" _ <- scalarType + , Full.ConstString _ <- node = mempty + | Definition.ScalarType "ID" _ <- scalarType + , Full.ConstInt _ <- node = mempty + | Definition.ScalarType "Float" _ <- scalarType + , Full.ConstFloat _ <- node = mempty + | Definition.ScalarType "Float" _ <- scalarType + , Full.ConstInt _ <- node = mempty + check (In.EnumBaseType enumType) Full.Node{ node } + | Definition.EnumType _ _ members <- enumType + , Full.ConstEnum memberValue <- node + , HashMap.member memberValue members = mempty + check (In.InputObjectBaseType objectType) Full.Node{ node } + | In.InputObjectType _ _ typeFields <- objectType + , Full.ConstObject valueFields <- node = + foldMap (checkObjectField typeFields) valueFields + check (In.ListBaseType listType) constValue@Full.Node{ .. } + | Full.ConstList listValues <- node = + foldMap (check listType) $ flip Full.Node location <$> listValues + | otherwise = check listType constValue + check inputType Full.Node{ .. } = pure $ Error + { message = concat + [ "Value " + , show node, " cannot be coerced to type \"" + , show inputType + , "\"." + ] + , locations = [location] + } + checkObjectField typeFields Full.ObjectField{..} + | Just typeField <- HashMap.lookup name typeFields + , In.InputField _ fieldType _ <- typeField = + check fieldType value + checkObjectField _ _ = mempty diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index d340d4e..24b0ad0 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -809,7 +809,7 @@ spec = } in validate queryString `shouldBe` [expected] - it "wrongly typed variable arguments" $ + it "rejects wrongly typed variable arguments" $ let queryString = [r| query catCommandArgQuery($catCommandArg: CatCommand) { cat { @@ -825,7 +825,7 @@ spec = } in validate queryString `shouldBe` [expected] - it "wrongly typed variable arguments" $ + it "rejects wrongly typed variable arguments" $ let queryString = [r| query intCannotGoIntoBoolean($intArg: Int) { dog { @@ -840,3 +840,35 @@ spec = , locations = [AST.Location 2 44] } in validate queryString `shouldBe` [expected] + + it "rejects values of incorrect types" $ + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: 3) + } + } + |] + expected = Error + { message = + "Value ConstInt 3 cannot be coerced to type \"Boolean\"." + , locations = [AST.Location 4 48] + } + in validate queryString `shouldBe` [expected] + + it "checks for (non-)nullable arguments" $ + let queryString = [r| + { + dog { + doesKnowCommand(dogCommand: null) + } + } + |] + expected = Error + { message = + "Field \"doesKnowCommand\" argument \"dogCommand\" of \ + \type \"DogCommand\" is required, but it was not \ + \provided." + , locations = [AST.Location 4 19] + } + in validate queryString `shouldBe` [expected]