Validate values

This commit is contained in:
Eugen Wissner 2021-02-03 05:42:10 +01:00
parent ebf4f4d24e
commit a034f2ce4d
4 changed files with 119 additions and 3 deletions

View File

@ -12,6 +12,7 @@ and this project adheres to
- `overlappingFieldsCanBeMergedRule` - `overlappingFieldsCanBeMergedRule`
- `possibleFragmentSpreadsRule` - `possibleFragmentSpreadsRule`
- `variablesInAllowedPositionRule` - `variablesInAllowedPositionRule`
- `valuesOfCorrectTypeRule`
- `Type.Schema.implementations` contains a map from interfaces and objects to - `Type.Schema.implementations` contains a map from interfaces and objects to
interfaces they implement. interfaces they implement.
- Show instances for GraphQL type definitions in the `Type` modules. - Show instances for GraphQL type definitions in the `Type` modules.

View File

@ -252,6 +252,9 @@ data ObjectField a = ObjectField
, location :: Location , location :: Location
} deriving (Eq, Show) } deriving (Eq, Show)
instance Functor ObjectField where
fmap f ObjectField{..} = ObjectField name (f <$> value) location
-- ** Variables -- ** Variables
-- | Variable definition. -- | Variable definition.

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -37,6 +38,7 @@ module Language.GraphQL.Validate.Rules
, uniqueInputFieldNamesRule , uniqueInputFieldNamesRule
, uniqueOperationNamesRule , uniqueOperationNamesRule
, uniqueVariableNamesRule , uniqueVariableNamesRule
, valuesOfCorrectTypeRule
, variablesInAllowedPositionRule , variablesInAllowedPositionRule
, variablesAreInputTypesRule , variablesAreInputTypesRule
) where ) where
@ -52,7 +54,7 @@ import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet) import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn) import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Sequence (Seq(..), (|>)) import Data.Sequence (Seq(..), (|>))
@ -97,6 +99,7 @@ specifiedRules =
, noFragmentCyclesRule , noFragmentCyclesRule
, possibleFragmentSpreadsRule , possibleFragmentSpreadsRule
-- Values -- Values
, valuesOfCorrectTypeRule
, knownInputFieldNamesRule , knownInputFieldNamesRule
, uniqueInputFieldNamesRule , uniqueInputFieldNamesRule
, providedRequiredInputFieldsRule , providedRequiredInputFieldsRule
@ -1523,3 +1526,80 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
] ]
, locations = [location'] , 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

View File

@ -809,7 +809,7 @@ spec =
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
it "wrongly typed variable arguments" $ it "rejects wrongly typed variable arguments" $
let queryString = [r| let queryString = [r|
query catCommandArgQuery($catCommandArg: CatCommand) { query catCommandArgQuery($catCommandArg: CatCommand) {
cat { cat {
@ -825,7 +825,7 @@ spec =
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
it "wrongly typed variable arguments" $ it "rejects wrongly typed variable arguments" $
let queryString = [r| let queryString = [r|
query intCannotGoIntoBoolean($intArg: Int) { query intCannotGoIntoBoolean($intArg: Int) {
dog { dog {
@ -840,3 +840,35 @@ spec =
, locations = [AST.Location 2 44] , locations = [AST.Location 2 44]
} }
in validate queryString `shouldBe` [expected] 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]