diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,19 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.11.1.0] - 2021-02-07 +### Added +- `Validate.Rules`: + - `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. +- Custom Show instances for type and value representations in the AST. +- `AST.Document.escape` escapes a single character in a `StringValue`. + ## [0.11.0.0] - 2020-11-07 ### Changed - `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread` @@ -400,6 +413,7 @@ ### Added - Data types for the GraphQL language. +[0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0 [0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0 [0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0 [0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,29 +3,10 @@ [![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org) [![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](https://build.caraus.tech/go/pipelines) -This implementation is relatively low-level by design, it doesn't provide any -mappings between the GraphQL types and Haskell's type system and avoids -compile-time magic. It focuses on flexibility instead, so other solutions can -be built on top of it. - -## State of the work - -For now this library provides: - -- Parser for the query and schema languages, as well as a printer for the query - language (minimizer and pretty-printer). -- Data structures to define a type system. -- Executor (queries, mutations and subscriptions are supported). -- Validation is work in progress. -- Introspection isn't available yet. - -But the idea is to be a Haskell port of -[`graphql-js`](https://github.com/graphql/graphql-js). - -For a more precise list of currently missing features see -[issues](https://www.caraus.tech/projects/pub-graphql/issues). +See https://www.caraus.tech/projects/pub-graphql. -## Documentation +Report issues on the +[bug tracker](https://www.caraus.tech/projects/pub-graphql/issues). API documentation is available through [Hackage](https://hackage.haskell.org/package/graphql). diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -1,10 +1,10 @@ cabal-version: 2.2 name: graphql -version: 0.11.0.0 +version: 0.11.1.0 license: MPL-2.0 AND BSD-3-Clause license-file: LICENSE LICENSE.MPL copyright: - (c) 2019-2020 Eugen Wissner, + (c) 2019-2021 Eugen Wissner, (c) 2015-2017 J. Daniel Navarro maintainer: belka@caraus.de @@ -60,24 +60,25 @@ default-language: Haskell2010 build-depends: - aeson >=1.4.7.1, + aeson >=1.5.5.1, base >=4.7 && <5, - conduit >=1.3.3, + conduit >=1.3.4, containers >=0.6.2.1, exceptions >=0.10.4, hspec-expectations >=0.8.2, - megaparsec >=8.0.0, + megaparsec >=9.0.1, parser-combinators >=1.2.1, scientific >=0.3.6.2, - text >=1.2.4.0, + text >=1.2.4.1, transformers >=0.5.6.2, - unordered-containers >=0.2.10.0 + unordered-containers >=0.2.13.0 test-suite graphql-test type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: tests other-modules: + Language.GraphQL.AST.DocumentSpec Language.GraphQL.AST.EncoderSpec Language.GraphQL.AST.LexerSpec Language.GraphQL.AST.ParserSpec @@ -85,7 +86,7 @@ Language.GraphQL.Execute.CoerceSpec Language.GraphQL.ExecuteSpec Language.GraphQL.Type.OutSpec - Language.GraphQL.ValidateSpec + Language.GraphQL.Validate.RulesSpec Test.DirectiveSpec Test.FragmentSpec Test.RootOperationSpec @@ -95,20 +96,20 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - QuickCheck >=2.13.2, - aeson >=1.4.7.1, + QuickCheck >=2.14.2, + aeson >=1.5.5.1, base >=4.7 && <5, - conduit >=1.3.3, + conduit >=1.3.4, containers >=0.6.2.1, exceptions >=0.10.4, graphql -any, - hspec >=2.7.4, + hspec >=2.7.8, hspec-expectations >=0.8.2, - hspec-megaparsec >=2.1.0, - megaparsec >=8.0.0, + hspec-megaparsec >=2.2.0, + megaparsec >=9.0.1, parser-combinators >=1.2.1, raw-strings-qq >=1.1, scientific >=0.3.6.2, - text >=1.2.4.0, + text >=1.2.4.1, transformers >=0.5.6.2, - unordered-containers >=0.2.10.0 + unordered-containers >=0.2.13.0 diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Safe #-} @@ -47,11 +48,15 @@ , UnionMemberTypes(..) , Value(..) , VariableDefinition(..) + , escape ) where +import Data.Char (ord) import Data.Foldable (toList) import Data.Int (Int32) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) +import Numeric (showFloat, showHex) import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) @@ -79,8 +84,11 @@ data Node a = Node { node :: a , location :: Location - } deriving (Eq, Show) + } deriving Eq +instance Show a => Show (Node a) where + show Node{ node } = show node + instance Functor Node where fmap f Node{..} = Node (f node) location @@ -218,6 +226,28 @@ -- ** Input Values +escape :: Char -> String +escape char' + | char' == '\\' = "\\\\" + | char' == '\"' = "\\\"" + | char' == '\b' = "\\b" + | char' == '\f' = "\\f" + | char' == '\n' = "\\n" + | char' == '\r' = "\\r" + | char' == '\t' = "\\t" + | char' < '\x0010' = unicode "\\u000" char' + | char' < '\x0020' = unicode "\\u00" char' + | otherwise = [char'] + where + unicode prefix uchar = prefix <> (showHex $ ord uchar) "" + +showList' :: Show a => [a] -> String +showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]" + +showObject :: Show a => [ObjectField a] -> String +showObject fields = + "{ " ++ intercalate ", " (show <$> fields) ++ " }" + -- | Input value (literal or variable). data Value = Variable Name @@ -229,8 +259,20 @@ | Enum Name | List [Value] | Object [ObjectField Value] - deriving (Eq, Show) + deriving Eq +instance Show Value where + showList = mappend . showList' + show (Variable variableName) = '$' : Text.unpack variableName + show (Int integer) = show integer + show (Float float) = show $ ConstFloat float + show (String text) = show $ ConstString text + show (Boolean boolean) = show boolean + show Null = "null" + show (Enum name) = Text.unpack name + show (List list) = show list + show (Object fields) = showObject fields + -- | Constant input value. data ConstValue = ConstInt Int32 @@ -241,8 +283,19 @@ | ConstEnum Name | ConstList [ConstValue] | ConstObject [ObjectField ConstValue] - deriving (Eq, Show) + deriving Eq +instance Show ConstValue where + showList = mappend . showList' + show (ConstInt integer) = show integer + show (ConstFloat float) = showFloat float mempty + show (ConstString text) = "\"" <> Text.foldr (mappend . escape) "\"" text + show (ConstBoolean boolean) = show boolean + show ConstNull = "null" + show (ConstEnum name) = Text.unpack name + show (ConstList list) = show list + show (ConstObject fields) = showObject fields + -- | Key-value pair. -- -- A list of 'ObjectField's represents a GraphQL object type. @@ -250,8 +303,14 @@ { name :: Name , value :: Node a , location :: Location - } deriving (Eq, Show) + } deriving Eq +instance Show a => Show (ObjectField a) where + show ObjectField{..} = Text.unpack name ++ ": " ++ show value + +instance Functor ObjectField where + fmap f ObjectField{..} = ObjectField name (f <$> value) location + -- ** Variables -- | Variable definition. @@ -281,8 +340,13 @@ = TypeNamed Name | TypeList Type | TypeNonNull NonNullType - deriving (Eq, Show) + deriving Eq +instance Show Type where + show (TypeNamed typeName) = Text.unpack typeName + show (TypeList listType) = concat ["[", show listType, "]"] + show (TypeNonNull nonNullType) = show nonNullType + -- | Represents type names. type NamedType = Name @@ -290,7 +354,11 @@ data NonNullType = NonNullTypeNamed Name | NonNullTypeList Type - deriving (Eq, Show) + deriving Eq + +instance Show NonNullType where + show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName + show (NonNullTypeList listType) = concat ["![", show listType, "]"] -- ** Directives diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -16,7 +16,6 @@ , value ) where -import Data.Char (ord) import Data.Foldable (fold) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) @@ -25,7 +24,7 @@ import qualified Data.Text.Lazy as Lazy.Text import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder -import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) +import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) import qualified Language.GraphQL.AST.Document as Full @@ -234,11 +233,12 @@ quote = Builder.singleton '\"' oneLine :: Text -> Builder -oneLine string = quote <> Text.foldr (mappend . escape) quote string +oneLine string = quote <> Text.foldr merge quote string + where + merge = mappend . Builder.fromString . Full.escape stringValue :: Formatter -> Text -> Lazy.Text -stringValue Minified string = Builder.toLazyText - $ quote <> Text.foldr (mappend . escape) quote string +stringValue Minified string = Builder.toLazyText $ oneLine string stringValue (Pretty indentation) string = if hasEscaped string then stringValue Minified string @@ -265,21 +265,6 @@ transformLine line' acc = Builder.fromLazyText (indent (indentation + 1)) <> line' <> newline <> acc - -escape :: Char -> Builder -escape char' - | char' == '\\' = Builder.fromString "\\\\" - | char' == '\"' = Builder.fromString "\\\"" - | char' == '\b' = Builder.fromString "\\b" - | char' == '\f' = Builder.fromString "\\f" - | char' == '\n' = Builder.fromString "\\n" - | char' == '\r' = Builder.fromString "\\r" - | char' == '\t' = Builder.fromString "\\t" - | char' < '\x0010' = unicode "\\u000" char' - | char' < '\x0020' = unicode "\\u00" char' - | otherwise = Builder.singleton char' - where - unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord) listValue :: Formatter -> [Full.Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -22,6 +22,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.String (IsString(..)) import Data.Text (Text) +import qualified Data.Text as Text import Language.GraphQL.AST (Name) import Prelude hiding (id) @@ -63,6 +64,9 @@ instance Eq ScalarType where (ScalarType this _) == (ScalarType that _) = this == that +instance Show ScalarType where + show (ScalarType typeName _) = Text.unpack typeName + -- | Enum type definition. -- -- Some leaf values of requests and input values are Enums. GraphQL serializes @@ -72,6 +76,9 @@ instance Eq EnumType where (EnumType this _ _) == (EnumType that _ _) = this == that + +instance Show EnumType where + show (EnumType typeName _ _) = Text.unpack typeName -- | Enum value is a single member of an 'EnumType'. newtype EnumValue = EnumValue (Maybe Text) diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -24,6 +24,7 @@ import Data.HashMap.Strict (HashMap) import Data.Text (Text) +import qualified Data.Text as Text import Language.GraphQL.AST.Document (Name) import qualified Language.GraphQL.Type.Definition as Definition @@ -40,6 +41,9 @@ instance Eq InputObjectType where (InputObjectType this _ _) == (InputObjectType that _ _) = this == that +instance Show InputObjectType where + show (InputObjectType typeName _ _) = Text.unpack typeName + -- | These types may be used as input types for arguments and directives. -- -- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping @@ -55,6 +59,16 @@ | NonNullInputObjectType InputObjectType | NonNullListType Type deriving Eq + +instance Show Type where + show (NamedScalarType scalarType) = show scalarType + show (NamedEnumType enumType) = show enumType + show (NamedInputObjectType inputObjectType) = show inputObjectType + show (ListType baseType) = concat ["[", show baseType, "]"] + show (NonNullScalarType scalarType) = '!' : show scalarType + show (NonNullEnumType enumType) = '!' : show enumType + show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType + show (NonNullListType baseType) = concat ["![", show baseType, "]"] -- | Field argument definition. data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -14,11 +14,14 @@ , Type(..) , directives , doesFragmentTypeApply + , implementations , instanceOf + , lookupCompositeField , lookupInputType , lookupTypeCondition , lookupTypeField , mutation + , outToComposite , subscription , query , types @@ -62,27 +65,32 @@ (Maybe (Out.ObjectType m)) Directives (HashMap Full.Name (Type m)) + (HashMap Full.Name [Type m]) -- | Schema query type. query :: forall m. Schema m -> Out.ObjectType m -query (Schema query' _ _ _ _) = query' +query (Schema query' _ _ _ _ _) = query' -- | Schema mutation type. mutation :: forall m. Schema m -> Maybe (Out.ObjectType m) -mutation (Schema _ mutation' _ _ _) = mutation' +mutation (Schema _ mutation' _ _ _ _) = mutation' -- | Schema subscription type. subscription :: forall m. Schema m -> Maybe (Out.ObjectType m) -subscription (Schema _ _ subscription' _ _) = subscription' +subscription (Schema _ _ subscription' _ _ _) = subscription' -- | Schema directive definitions. directives :: forall m. Schema m -> Directives -directives (Schema _ _ _ directives' _) = directives' +directives (Schema _ _ _ directives' _ _) = directives' -- | Types referenced by the schema. types :: forall m. Schema m -> HashMap Full.Name (Type m) -types (Schema _ _ _ _ types') = types' +types (Schema _ _ _ _ types' _) = types' +-- | Interface implementations. +implementations :: forall m. Schema m -> HashMap Full.Name [Type m] +implementations (Schema _ _ _ _ _ implementations') = implementations' + -- | These types may describe the parent context of a selection set. data CompositeType m = CompositeUnionType (Out.UnionType m) @@ -160,12 +168,16 @@ <$> lookupInputType nonNull types' lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a) -lookupTypeField fieldName = \case - Out.ObjectBaseType objectType -> - objectChild objectType - Out.InterfaceBaseType interfaceType -> - interfaceChild interfaceType - Out.ListBaseType listType -> lookupTypeField fieldName listType +lookupTypeField fieldName outputType = + outToComposite outputType >>= lookupCompositeField fieldName + +lookupCompositeField :: forall a + . Full.Name + -> CompositeType a + -> Maybe (Out.Field a) +lookupCompositeField fieldName = \case + CompositeObjectType objectType -> objectChild objectType + CompositeInterfaceType interfaceType -> interfaceChild interfaceType _ -> Nothing where objectChild (Out.ObjectType _ _ _ resolvers) = @@ -174,3 +186,12 @@ HashMap.lookup fieldName fields resolverType (Out.ValueResolver objectField _) = objectField resolverType (Out.EventStreamResolver objectField _ _) = objectField + +outToComposite :: forall a. Out.Type a -> Maybe (CompositeType a) +outToComposite = \case + Out.ObjectBaseType objectType -> Just $ CompositeObjectType objectType + Out.InterfaceBaseType interfaceType -> + Just $ CompositeInterfaceType interfaceType + Out.UnionBaseType unionType -> Just $ CompositeUnionType unionType + Out.ListBaseType listType -> outToComposite listType + _ -> Nothing diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -38,6 +38,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe (fromMaybe) import Data.Text (Text) +import qualified Data.Text as Text import Language.GraphQL.AST (Name) import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In @@ -52,6 +53,9 @@ instance forall a. Eq (ObjectType a) where (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that +instance forall a. Show (ObjectType a) where + show (ObjectType typeName _ _ _) = Text.unpack typeName + -- | Interface Type Definition. -- -- When a field can return one of a heterogeneous set of types, a Interface type @@ -63,6 +67,9 @@ instance forall a. Eq (InterfaceType a) where (InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that +instance forall a. Show (InterfaceType a) where + show (InterfaceType typeName _ _ _) = Text.unpack typeName + -- | Union Type Definition. -- -- When a field can return one of a heterogeneous set of types, a Union type is @@ -72,6 +79,9 @@ instance forall a. Eq (UnionType a) where (UnionType this _ _) == (UnionType that _ _) = this == that +instance forall a. Show (UnionType a) where + show (UnionType typeName _ _) = Text.unpack typeName + -- | Output object field definition. data Field m = Field (Maybe Text) -- ^ Description. @@ -97,6 +107,20 @@ | NonNullUnionType (UnionType m) | NonNullListType (Type m) deriving Eq + +instance forall a. Show (Type a) where + show (NamedScalarType scalarType) = show scalarType + show (NamedEnumType enumType) = show enumType + show (NamedObjectType inputObjectType) = show inputObjectType + show (NamedInterfaceType interfaceType) = show interfaceType + show (NamedUnionType unionType) = show unionType + show (ListType baseType) = concat ["[", show baseType, "]"] + show (NonNullScalarType scalarType) = '!' : show scalarType + show (NonNullEnumType enumType) = '!' : show enumType + show (NonNullObjectType inputObjectType) = '!' : show inputObjectType + show (NonNullInterfaceType interfaceType) = '!' : show interfaceType + show (NonNullUnionType unionType) = '!' : show unionType + show (NonNullListType baseType) = concat ["![", show baseType, "]"] -- | Matches either 'NamedScalarType' or 'NonNullScalarType'. pattern ScalarBaseType :: forall m. ScalarType -> Type m diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -23,6 +23,7 @@ , Schema , Type(..) , directives + , implementations , mutation , subscription , query @@ -41,9 +42,11 @@ -> Directives -- ^ Directive definitions. -> Schema m -- ^ Schema. schema queryRoot mutationRoot subscriptionRoot directiveDefinitions = - Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes + Internal.Schema queryRoot mutationRoot subscriptionRoot + allDirectives collectedTypes collectedImplementations where collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot + collectedImplementations = collectImplementations collectedTypes allDirectives = HashMap.union directiveDefinitions defaultDirectives defaultDirectives = HashMap.fromList [ ("skip", skipDirective) @@ -153,3 +156,20 @@ polymorphicTraverser interfaces fields = flip (foldr visitFields) fields . flip (foldr traverseInterfaceType) interfaces + +-- | Looks for objects and interfaces under the schema types and collects the +-- interfaces they implement. +collectImplementations :: forall m + . HashMap Full.Name (Type m) + -> HashMap Full.Name [Type m] +collectImplementations = HashMap.foldr go HashMap.empty + where + go implementation@(InterfaceType interfaceType) accumulator = + let Out.InterfaceType _ _ interfaces _ = interfaceType + in foldr (add implementation) accumulator interfaces + go implementation@(ObjectType objectType) accumulator = + let Out.ObjectType _ _ interfaces _ = objectType + in foldr (add implementation) accumulator interfaces + go _ accumulator = accumulator + add implementation (Out.InterfaceType typeName _ _ _) accumulator = + HashMap.insertWith (++) typeName [implementation] accumulator diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -210,7 +210,7 @@ directives context rule scalarLocation directives' Full.ObjectTypeDefinition _ _ _ directives' fields -> directives context rule objectLocation directives' - >< foldMap (fieldDefinition context rule) fields + >< foldMap (fieldDefinition context rule) fields Full.InterfaceTypeDefinition _ _ directives' fields -> directives context rule interfaceLocation directives' >< foldMap (fieldDefinition context rule) fields diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs --- 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 #-} @@ -24,6 +25,8 @@ , noUndefinedVariablesRule , noUnusedFragmentsRule , noUnusedVariablesRule + , overlappingFieldsCanBeMergedRule + , possibleFragmentSpreadsRule , providedRequiredInputFieldsRule , providedRequiredArgumentsRule , scalarLeafsRule @@ -35,22 +38,24 @@ , uniqueInputFieldNamesRule , uniqueOperationNamesRule , uniqueVariableNamesRule + , valuesOfCorrectTypeRule + , variablesInAllowedPositionRule , variablesAreInputTypesRule ) where import Control.Monad ((>=>), foldM) import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT) +import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Data.Bifunctor (first) -import Data.Foldable (find, toList) +import Data.Foldable (find, fold, foldl', 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.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Ord (comparing) import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq @@ -80,6 +85,7 @@ -- Fields , fieldsOnCorrectTypeRule , scalarLeafsRule + , overlappingFieldsCanBeMergedRule -- Arguments. , knownArgumentNamesRule , uniqueArgumentNamesRule @@ -91,7 +97,9 @@ , noUnusedFragmentsRule , fragmentSpreadTargetDefinedRule , noFragmentCyclesRule + , possibleFragmentSpreadsRule -- Values + , valuesOfCorrectTypeRule , knownInputFieldNamesRule , uniqueInputFieldNamesRule , providedRequiredInputFieldsRule @@ -104,6 +112,7 @@ , variablesAreInputTypesRule , noUndefinedVariablesRule , noUnusedVariablesRule + , variablesInAllowedPositionRule ] -- | Definition must be OperationDefinition or FragmentDefinition. @@ -320,10 +329,8 @@ 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 + typeCondition <- findSpreadTarget fragmentName case HashMap.lookup typeCondition types' of Nothing -> pure $ Error { message = spreadError fragmentName typeCondition @@ -342,10 +349,6 @@ 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 @@ -451,8 +454,7 @@ noFragmentCyclesRule :: forall m. Rule m noFragmentCyclesRule = FragmentDefinitionRule $ \case Full.FragmentDefinition fragmentName _ _ selections location' -> do - state <- evalStateT (collectFields selections) - (0, fragmentName) + state <- evalStateT (collectCycles selections) (0, fragmentName) let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) case reverse spreadPath of x : _ | x == fragmentName -> pure $ Error @@ -467,10 +469,10 @@ } _ -> lift mempty where - collectFields :: Traversable t + collectCycles :: Traversable t => t Full.Selection -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int) - collectFields selectionSet = foldM forEach HashMap.empty selectionSet + collectCycles selectionSet = foldM forEach HashMap.empty selectionSet forEach accumulator = \case Full.FieldSelection fieldSelection -> forField accumulator fieldSelection Full.InlineFragmentSelection fragmentSelection -> @@ -487,15 +489,15 @@ then pure newAccumulator else collectFromSpread fragmentName newAccumulator forInline accumulator (Full.InlineFragment _ _ selections _) = - (accumulator <>) <$> collectFields selections + (accumulator <>) <$> collectCycles selections forField accumulator (Full.Field _ _ _ _ selections _) = - (accumulator <>) <$> collectFields selections + (accumulator <>) <$> collectCycles selections collectFromSpread fragmentName accumulator = do ast' <- lift $ asks ast case findFragmentDefinition fragmentName ast' of Nothing -> pure accumulator Just (Full.FragmentDefinition _ _ _ selections _) -> - (accumulator <>) <$> collectFields selections + (accumulator <>) <$> collectCycles selections findFragmentDefinition :: Text -> NonEmpty Full.Definition @@ -531,15 +533,22 @@ extract (Full.Directive directiveName _ location') = (directiveName, location') -filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error +groupSorted :: forall a. (a -> Text) -> [a] -> [[a]] +groupSorted getName = groupBy equalByName . sortOn getName + where + equalByName lhs rhs = getName lhs == getName rhs + +filterDuplicates :: forall a + . (a -> (Text, Full.Location)) + -> String + -> [a] + -> Seq Error filterDuplicates extract nodeType = Seq.fromList . fmap makeError . filter ((> 1) . length) - . groupBy equalByName - . sortOn getName + . groupSorted getName where getName = fst . extract - equalByName lhs rhs = getName lhs == getName rhs makeError directives' = Error { message = makeMessage $ head directives' , locations = snd . extract <$> directives' @@ -647,12 +656,9 @@ 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 + nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName + case nonVisitedFragmentDefinition of + Just fragmentDefinition -> diveIntoSpread fragmentDefinition _ -> lift $ lift mempty diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _) = filterSelections' selections @@ -710,7 +716,7 @@ fieldRule parentType (Full.Field _ fieldName _ _ _ location') | Just objectType <- parentType , Nothing <- Type.lookupTypeField fieldName objectType - , Just typeName <- compositeTypeName objectType = pure $ Error + , Just typeName <- typeNameIfComposite objectType = pure $ Error { message = errorMessage fieldName typeName , locations = [location'] } @@ -723,21 +729,18 @@ , "\"." ] -compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name -compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = - Just typeName -compositeTypeName (Out.InterfaceBaseType interfaceType) = +compositeTypeName :: forall m. Type.CompositeType m -> Full.Name +compositeTypeName (Type.CompositeObjectType (Out.ObjectType typeName _ _ _)) = + typeName +compositeTypeName (Type.CompositeInterfaceType 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 + in typeName +compositeTypeName (Type.CompositeUnionType (Out.UnionType typeName _ _)) = + typeName +typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name +typeNameIfComposite = fmap compositeTypeName . Type.outToComposite + -- | Field selections on scalars or enums are never allowed, because they are -- the leaf nodes of any GraphQL query. scalarLeafsRule :: forall m. Rule m @@ -794,7 +797,7 @@ where fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _) | Just typeField <- Type.lookupTypeField fieldName objectType - , Just typeName <- compositeTypeName objectType = + , Just typeName <- typeNameIfComposite objectType = lift $ foldr (go typeName fieldName typeField) Seq.empty arguments fieldRule _ _ = lift mempty go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors @@ -1013,3 +1016,590 @@ , Text.unpack typeName , "\" is required, but it was not provided." ] + +-- | If multiple field selections with the same response names are encountered +-- during execution, the field and arguments to execute and the resulting value +-- should be unambiguous. Therefore any two field selections which might both be +-- encountered for the same object are only valid if they are equivalent. +-- +-- For simple hand‐written GraphQL, this rule is obviously a clear developer +-- error, however nested fragments can make this difficult to detect manually. +overlappingFieldsCanBeMergedRule :: Rule m +overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case + Full.SelectionSet selectionSet _ -> do + schema' <- asks schema + go (toList selectionSet) + $ Type.CompositeObjectType + $ Schema.query schema' + Full.OperationDefinition operationType _ _ _ selectionSet _ -> do + schema' <- asks schema + let root = go (toList selectionSet) . Type.CompositeObjectType + case operationType of + Full.Query -> root $ Schema.query schema' + Full.Mutation + | Just objectType <- Schema.mutation schema' -> root objectType + Full.Subscription + | Just objectType <- Schema.mutation schema' -> root objectType + _ -> lift mempty + where + go selectionSet selectionType = do + fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty + fieldsInSetCanMerge fieldTuples + fieldsInSetCanMerge :: forall m + . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m)) + -> ReaderT (Validation m) Seq Error + fieldsInSetCanMerge fieldTuples = do + validation <- ask + let (lonely, paired) = flattenPairs fieldTuples + let reader = flip runReaderT validation + lift $ foldMap (reader . visitLonelyFields) lonely + <> foldMap (reader . forEachFieldTuple) paired + forEachFieldTuple :: forall m + . (FieldInfo m, FieldInfo m) + -> ReaderT (Validation m) Seq Error + forEachFieldTuple (fieldA, fieldB) = + case (parent fieldA, parent fieldB) of + (parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{}) + | parentA /= parentB -> sameResponseShape fieldA fieldB + _ -> mapReaderT (checkEquality (node fieldA) (node fieldB)) + $ sameResponseShape fieldA fieldB + checkEquality fieldA fieldB Seq.Empty + | Full.Field _ fieldNameA _ _ _ _ <- fieldA + , Full.Field _ fieldNameB _ _ _ _ <- fieldB + , fieldNameA /= fieldNameB = pure $ makeError fieldA fieldB + | Full.Field _ fieldNameA argumentsA _ _ locationA <- fieldA + , Full.Field _ _ argumentsB _ _ locationB <- fieldB + , argumentsA /= argumentsB = + let message = concat + [ "Fields \"" + , Text.unpack fieldNameA + , "\" conflict because they have different arguments. Use " + , "different aliases on the fields to fetch both if this " + , "was intentional." + ] + in pure $ Error message [locationB, locationA] + checkEquality _ _ previousErrors = previousErrors + visitLonelyFields FieldInfo{..} = + let Full.Field _ _ _ _ subSelections _ = node + compositeFieldType = Type.outToComposite type' + in maybe (lift Seq.empty) (go subSelections) compositeFieldType + sameResponseShape :: forall m + . FieldInfo m + -> FieldInfo m + -> ReaderT (Validation m) Seq Error + sameResponseShape fieldA fieldB = + let Full.Field _ _ _ _ selectionsA _ = node fieldA + Full.Field _ _ _ _ selectionsB _ = node fieldB + in case unwrapTypes (type' fieldA) (type' fieldB) of + Left True -> lift mempty + Right (compositeA, compositeB) -> do + validation <- ask + let collectFields' composite = flip runReaderT validation + . flip evalStateT HashSet.empty + . collectFields composite + let collectA = collectFields' compositeA selectionsA + let collectB = collectFields' compositeB selectionsB + fieldsInSetCanMerge + $ foldl' (HashMap.unionWith (<>)) HashMap.empty + $ collectA <> collectB + _ -> pure $ makeError (node fieldA) (node fieldB) + makeError fieldA fieldB = + let Full.Field aliasA fieldNameA _ _ _ locationA = fieldA + Full.Field _ fieldNameB _ _ _ locationB = fieldB + message = concat + [ "Fields \"" + , Text.unpack (fromMaybe fieldNameA aliasA) + , "\" conflict because \"" + , Text.unpack fieldNameB + , "\" and \"" + , Text.unpack fieldNameA + , "\" are different fields. Use different aliases on the fields " + , "to fetch both if this was intentional." + ] + in Error message [locationB, locationA] + unwrapTypes typeA@Out.ScalarBaseType{} typeB@Out.ScalarBaseType{} = + Left $ typeA == typeB + unwrapTypes typeA@Out.EnumBaseType{} typeB@Out.EnumBaseType{} = + Left $ typeA == typeB + unwrapTypes (Out.ListType listA) (Out.ListType listB) = + unwrapTypes listA listB + unwrapTypes (Out.NonNullListType listA) (Out.NonNullListType listB) = + unwrapTypes listA listB + unwrapTypes typeA typeB + | Out.isNonNullType typeA == Out.isNonNullType typeB + , Just compositeA <- Type.outToComposite typeA + , Just compositeB <- Type.outToComposite typeB = + Right (compositeA, compositeB) + | otherwise = Left False + flattenPairs :: forall m + . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m)) + -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m)) + flattenPairs xs = HashMap.foldr splitSingleFields (Seq.empty, Seq.empty) + $ foldr lookupTypeField [] <$> xs + splitSingleFields :: forall m + . [FieldInfo m] + -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m)) + -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m)) + splitSingleFields [head'] (fields, pairList) = (fields |> head', pairList) + splitSingleFields xs (fields, pairList) = (fields, pairs pairList xs) + lookupTypeField (field, parentType) accumulator = + let Full.Field _ fieldName _ _ _ _ = field + in case Type.lookupCompositeField fieldName parentType of + Nothing -> accumulator + Just (Out.Field _ typeField _) -> + FieldInfo field typeField parentType : accumulator + pairs :: forall m + . Seq (FieldInfo m, FieldInfo m) + -> [FieldInfo m] + -> Seq (FieldInfo m, FieldInfo m) + pairs accumulator [] = accumulator + pairs accumulator (fieldA : fields) = + pair fieldA (pairs accumulator fields) fields + pair _ accumulator [] = accumulator + pair field accumulator (fieldA : fields) = + pair field accumulator fields |> (field, fieldA) + collectFields objectType = accumulateFields objectType mempty + accumulateFields = foldM . forEach + forEach parentType accumulator = \case + Full.FieldSelection fieldSelection -> + forField parentType accumulator fieldSelection + Full.FragmentSpreadSelection fragmentSelection -> + forSpread accumulator fragmentSelection + Full.InlineFragmentSelection fragmentSelection -> + forInline parentType accumulator fragmentSelection + forField parentType accumulator field@(Full.Field alias fieldName _ _ _ _) = + let key = fromMaybe fieldName alias + value = (field, parentType) :| [] + in pure $ HashMap.insertWith (<>) key value accumulator + forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do + inVisitetFragments <- gets $ HashSet.member fragmentName + if inVisitetFragments + then pure accumulator + else collectFromSpread fragmentName accumulator + forInline parentType accumulator = \case + Full.InlineFragment maybeType _ selections _ + | Just typeCondition <- maybeType -> + collectFromFragment typeCondition selections accumulator + | otherwise -> accumulateFields parentType accumulator $ toList selections + collectFromFragment typeCondition selectionSet' accumulator = do + types' <- lift $ asks $ Schema.types . schema + case Type.lookupTypeCondition typeCondition types' of + Nothing -> pure accumulator + Just compositeType -> + accumulateFields compositeType accumulator $ toList selectionSet' + collectFromSpread fragmentName accumulator = do + modify $ HashSet.insert fragmentName + ast' <- lift $ asks ast + case findFragmentDefinition fragmentName ast' of + Nothing -> pure accumulator + Just (Full.FragmentDefinition _ typeCondition _ selectionSet' _) -> + collectFromFragment typeCondition selectionSet' accumulator + +data FieldInfo m = FieldInfo + { node :: Full.Field + , type' :: Out.Type m + , parent :: Type.CompositeType m + } + +-- | Fragments are declared on a type and will only apply when the runtime +-- object type matches the type condition. They also are spread within the +-- context of a parent type. A fragment spread is only valid if its type +-- condition could ever apply within the parent type. +possibleFragmentSpreadsRule :: forall m. Rule m +possibleFragmentSpreadsRule = SelectionRule go + where + go (Just parentType) (Full.InlineFragmentSelection fragmentSelection) + | Full.InlineFragment maybeType _ _ location' <- fragmentSelection + , Just typeCondition <- maybeType = do + (fragmentTypeName, parentTypeName) <- + compareTypes typeCondition parentType + pure $ Error + { message = concat + [ "Fragment cannot be spread here as objects of type \"" + , Text.unpack parentTypeName + , "\" can never be of type \"" + , Text.unpack fragmentTypeName + , "\"." + ] + , locations = [location'] + } + go (Just parentType) (Full.FragmentSpreadSelection fragmentSelection) + | Full.FragmentSpread fragmentName _ location' <- fragmentSelection = do + typeCondition <- findSpreadTarget fragmentName + (fragmentTypeName, parentTypeName) <- + compareTypes typeCondition parentType + pure $ Error + { message = concat + [ "Fragment \"" + , Text.unpack fragmentName + , "\" cannot be spread here as objects of type \"" + , Text.unpack parentTypeName + , "\" can never be of type \"" + , Text.unpack fragmentTypeName + , "\"." + ] + , locations = [location'] + } + go _ _ = lift mempty + compareTypes typeCondition parentType = do + types' <- asks $ Schema.types . schema + fragmentType <- lift + $ maybeToSeq + $ Type.lookupTypeCondition typeCondition types' + parentComposite <- lift + $ maybeToSeq + $ Type.outToComposite parentType + possibleFragments <- getPossibleTypes fragmentType + possibleParents <- getPossibleTypes parentComposite + let fragmentTypeName = compositeTypeName fragmentType + let parentTypeName = compositeTypeName parentComposite + if HashSet.null $ HashSet.intersection possibleFragments possibleParents + then pure (fragmentTypeName, parentTypeName) + else lift mempty + getPossibleTypeList (Type.CompositeObjectType objectType) = + pure [Schema.ObjectType objectType] + getPossibleTypeList (Type.CompositeUnionType unionType) = + let Out.UnionType _ _ members = unionType + in pure $ Schema.ObjectType <$> members + getPossibleTypeList (Type.CompositeInterfaceType interfaceType) = + let Out.InterfaceType typeName _ _ _ = interfaceType + in HashMap.lookupDefault [] typeName + <$> asks (Schema.implementations . schema) + getPossibleTypes compositeType + = foldr (HashSet.insert . internalTypeName) HashSet.empty + <$> getPossibleTypeList compositeType + +internalTypeName :: forall m. Schema.Type m -> Full.Name +internalTypeName (Schema.ScalarType (Definition.ScalarType typeName _)) = + typeName +internalTypeName (Schema.EnumType (Definition.EnumType typeName _ _)) = typeName +internalTypeName (Schema.ObjectType (Out.ObjectType typeName _ _ _)) = typeName +internalTypeName (Schema.InputObjectType (In.InputObjectType typeName _ _)) = + typeName +internalTypeName (Schema.InterfaceType (Out.InterfaceType typeName _ _ _)) = + typeName +internalTypeName (Schema.UnionType (Out.UnionType typeName _ _)) = typeName + +findSpreadTarget :: Full.Name -> ReaderT (Validation m1) Seq Full.TypeCondition +findSpreadTarget fragmentName = do + ast' <- asks ast + let target = find (isSpreadTarget fragmentName) ast' + lift $ maybeToSeq $ target >>= extractTypeCondition + where + extractTypeCondition (viewFragment -> Just fragmentDefinition) = + let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition + in Just typeCondition + extractTypeCondition _ = Nothing + +visitFragmentDefinition :: forall m + . Text + -> ValidationState m (Maybe Full.FragmentDefinition) +visitFragmentDefinition fragmentName = 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 -> pure $ Just fragmentDefinition + _ -> pure Nothing + +-- | Variable usages must be compatible with the arguments they are passed to. +-- +-- Validation failures occur when variables are used in the context of types +-- that are complete mismatches, or if a nullable type in a variable is passed +-- to a non‐null argument type. +variablesInAllowedPositionRule :: forall m. Rule m +variablesInAllowedPositionRule = OperationDefinitionRule $ \case + Full.OperationDefinition operationType _ variables _ selectionSet _ -> do + schema' <- asks schema + let root = go variables (toList selectionSet) . Type.CompositeObjectType + case operationType of + Full.Query -> root $ Schema.query schema' + Full.Mutation + | Just objectType <- Schema.mutation schema' -> root objectType + Full.Subscription + | Just objectType <- Schema.mutation schema' -> root objectType + _ -> lift mempty + _ -> lift mempty + where + go variables selections selectionType = mapReaderT (foldr (<>) Seq.empty) + $ flip evalStateT HashSet.empty + $ visitSelectionSet variables selectionType + $ toList selections + visitSelectionSet :: Foldable t + => [Full.VariableDefinition] + -> Type.CompositeType m + -> t Full.Selection + -> ValidationState m (Seq Error) + visitSelectionSet variables selectionType selections = + foldM (evaluateSelection variables selectionType) mempty selections + evaluateFieldSelection variables selections accumulator = \case + Just newParentType -> do + let folder = evaluateSelection variables newParentType + selectionErrors <- foldM folder accumulator selections + pure $ accumulator <> selectionErrors + Nothing -> pure accumulator + evaluateSelection :: [Full.VariableDefinition] + -> Type.CompositeType m + -> Seq Error + -> Full.Selection + -> ValidationState m (Seq Error) + evaluateSelection variables selectionType accumulator selection + | Full.FragmentSpreadSelection spread <- selection + , Full.FragmentSpread fragmentName _ _ <- spread = do + types' <- lift $ asks $ Schema.types . schema + nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName + case nonVisitedFragmentDefinition of + Just fragmentDefinition + | Full.FragmentDefinition _ typeCondition _ _ _ <- fragmentDefinition + , Just spreadType <- Type.lookupTypeCondition typeCondition types' -> do + spreadErrors <- spreadVariables variables spread + selectionErrors <- diveIntoSpread variables spreadType fragmentDefinition + pure $ accumulator <> spreadErrors <> selectionErrors + _ -> lift $ lift mempty + | Full.FieldSelection fieldSelection <- selection + , Full.Field _ fieldName _ _ subselections _ <- fieldSelection = + case Type.lookupCompositeField fieldName selectionType of + Just (Out.Field _ typeField argumentTypes) -> do + fieldErrors <- fieldVariables variables argumentTypes fieldSelection + selectionErrors <- evaluateFieldSelection variables subselections accumulator + $ Type.outToComposite typeField + pure $ selectionErrors <> fieldErrors + Nothing -> pure accumulator + | Full.InlineFragmentSelection inlineSelection <- selection + , Full.InlineFragment typeCondition _ subselections _ <- inlineSelection = do + types' <- lift $ asks $ Schema.types . schema + let inlineType = fromMaybe selectionType + $ typeCondition >>= flip Type.lookupTypeCondition types' + fragmentErrors <- inlineVariables variables inlineSelection + let folder = evaluateSelection variables inlineType + selectionErrors <- foldM folder accumulator subselections + pure $ accumulator <> fragmentErrors <> selectionErrors + inlineVariables variables inline + | Full.InlineFragment _ directives' _ _ <- inline = + mapDirectives variables directives' + fieldVariables :: [Full.VariableDefinition] + -> In.Arguments + -> Full.Field + -> ValidationState m (Seq Error) + fieldVariables variables argumentTypes fieldSelection = do + let Full.Field _ _ arguments directives' _ _ = fieldSelection + argumentErrors <- mapArguments variables argumentTypes arguments + directiveErrors <- mapDirectives variables directives' + pure $ argumentErrors <> directiveErrors + spreadVariables variables (Full.FragmentSpread _ directives' _) = + mapDirectives variables directives' + diveIntoSpread variables fieldType fragmentDefinition = do + let Full.FragmentDefinition _ _ directives' selections _ = + fragmentDefinition + selectionErrors <- visitSelectionSet variables fieldType selections + directiveErrors <- mapDirectives variables directives' + pure $ selectionErrors <> directiveErrors + findDirectiveVariables variables directive = do + let Full.Directive directiveName arguments _ = directive + directiveDefinitions <- lift $ asks $ Schema.directives . schema + case HashMap.lookup directiveName directiveDefinitions of + Just (Schema.Directive _ _ directiveArguments) -> + mapArguments variables directiveArguments arguments + Nothing -> pure mempty + mapArguments variables argumentTypes = fmap fold + . traverse (findArgumentVariables variables argumentTypes) + mapDirectives variables = fmap fold + <$> traverse (findDirectiveVariables variables) + lookupInputObject variables objectFieldValue locationInfo + | Full.Node{ node = Full.Object objectFields } <- objectFieldValue + , Just (expectedType, _) <- locationInfo + , In.InputObjectBaseType inputObjectType <- expectedType + , In.InputObjectType _ _ fieldTypes' <- inputObjectType = + fold <$> traverse (traverseObjectField variables fieldTypes') objectFields + | otherwise = pure mempty + maybeUsageAllowed variableName variables locationInfo + | Just (locationType, locationValue) <- locationInfo + , findVariableDefinition' <- findVariableDefinition variableName + , Just variableDefinition <- find findVariableDefinition' variables + = maybeToSeq + <$> isVariableUsageAllowed locationType locationValue variableDefinition + | otherwise = pure mempty + findArgumentVariables :: [Full.VariableDefinition] + -> HashMap Full.Name In.Argument + -> Full.Argument + -> ValidationState m (Seq Error) + findArgumentVariables variables argumentTypes argument + | Full.Argument argumentName argumentValue _ <- argument + , Full.Node{ node = Full.Variable variableName } <- argumentValue + = maybeUsageAllowed variableName variables + $ locationPair extractArgument argumentTypes argumentName + | Full.Argument argumentName argumentValue _ <- argument + = lookupInputObject variables argumentValue + $ locationPair extractArgument argumentTypes argumentName + extractField (In.InputField _ locationType locationValue) = + (locationType, locationValue) + extractArgument (In.Argument _ locationType locationValue) = + (locationType, locationValue) + locationPair extract fieldTypes name = + extract <$> HashMap.lookup name fieldTypes + traverseObjectField variables fieldTypes Full.ObjectField{..} + | Full.Node{ node = Full.Variable variableName } <- value + = maybeUsageAllowed variableName variables + $ locationPair extractField fieldTypes name + | otherwise = lookupInputObject variables value + $ locationPair extractField fieldTypes name + findVariableDefinition variableName variableDefinition = + let Full.VariableDefinition variableName' _ _ _ = variableDefinition + in variableName == variableName' + isVariableUsageAllowed locationType locationDefaultValue variableDefinition + | Full.VariableDefinition _ variableType _ _ <- variableDefinition + , Full.TypeNonNull _ <- variableType = + typesCompatibleOrError variableDefinition locationType + | Just nullableLocationType <- unwrapInType locationType + , Full.VariableDefinition _ variableType variableDefaultValue _ <- + variableDefinition + , hasNonNullVariableDefaultValue' <- + hasNonNullVariableDefaultValue variableDefaultValue + , hasLocationDefaultValue <- isJust locationDefaultValue = + if (hasNonNullVariableDefaultValue' || hasLocationDefaultValue) + && areTypesCompatible variableType nullableLocationType + then pure Nothing + else pure $ makeError variableDefinition locationType + | otherwise = typesCompatibleOrError variableDefinition locationType + typesCompatibleOrError variableDefinition locationType + | Full.VariableDefinition _ variableType _ _ <- variableDefinition + , areTypesCompatible variableType locationType = pure Nothing + | otherwise = pure $ makeError variableDefinition locationType + areTypesCompatible nonNullType (unwrapInType -> Just nullableLocationType) + | Full.TypeNonNull (Full.NonNullTypeNamed namedType) <- nonNullType = + areTypesCompatible (Full.TypeNamed namedType) nullableLocationType + | Full.TypeNonNull (Full.NonNullTypeList namedList) <- nonNullType = + areTypesCompatible (Full.TypeList namedList) nullableLocationType + areTypesCompatible _ (In.isNonNullType -> True) = False + areTypesCompatible (Full.TypeNonNull nonNullType) locationType + | Full.NonNullTypeNamed namedType <- nonNullType = + areTypesCompatible (Full.TypeNamed namedType) locationType + | Full.NonNullTypeList namedType <- nonNullType = + areTypesCompatible (Full.TypeList namedType) locationType + areTypesCompatible variableType locationType + | Full.TypeList itemVariableType <- variableType + , In.ListType itemLocationType <- locationType = + areTypesCompatible itemVariableType itemLocationType + | areIdentical variableType locationType = True + | otherwise = False + areIdentical (Full.TypeList typeList) (In.ListType itemLocationType) = + areIdentical typeList itemLocationType + areIdentical (Full.TypeNonNull nonNullType) locationType + | Full.NonNullTypeList nonNullList <- nonNullType + , In.NonNullListType itemLocationType <- locationType = + areIdentical nonNullList itemLocationType + | Full.NonNullTypeNamed _ <- nonNullType + , In.ListBaseType _ <- locationType = False + | Full.NonNullTypeNamed nonNullList <- nonNullType + , In.isNonNullType locationType = + nonNullList == inputTypeName locationType + areIdentical (Full.TypeNamed _) (In.ListBaseType _) = False + areIdentical (Full.TypeNamed typeNamed) locationType + | not $ In.isNonNullType locationType = + typeNamed == inputTypeName locationType + areIdentical _ _ = False + hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False + hasNonNullVariableDefaultValue Nothing = False + hasNonNullVariableDefaultValue _ = True + unwrapInType (In.NonNullScalarType nonNullType) = + Just $ In.NamedScalarType nonNullType + unwrapInType (In.NonNullEnumType nonNullType) = + Just $ In.NamedEnumType nonNullType + unwrapInType (In.NonNullInputObjectType nonNullType) = + Just $ In.NamedInputObjectType nonNullType + unwrapInType (In.NonNullListType nonNullType) = + Just $ In.ListType nonNullType + unwrapInType _ = Nothing + makeError variableDefinition expectedType = + let Full.VariableDefinition variableName variableType _ location' = + variableDefinition + in Just $ Error + { message = concat + [ "Variable \"$" + , Text.unpack variableName + , "\" of type \"" + , show variableType + , "\" used in position expecting type \"" + , show expectedType + , "\"." + ] + , 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/AST/DocumentSpec.hs b/tests/Language/GraphQL/AST/DocumentSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/AST/DocumentSpec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.AST.DocumentSpec + ( spec + ) where + +import Language.GraphQL.AST.Document +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "Document" $ do + it "shows objects" $ + let zero = Location 0 0 + object = ConstObject + [ ObjectField "field1" (Node (ConstFloat 1.2) zero) zero + , ObjectField "field2" (Node ConstNull zero) zero + ] + expected = "{ field1: 1.2, field2: null }" + in show object `shouldBe` expected diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -0,0 +1,914 @@ +{- 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 OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Language.GraphQL.Validate.RulesSpec + ( spec + ) where + +import Data.Foldable (toList) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Language.GraphQL.AST as AST +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Validate +import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) +import Text.Megaparsec (parse, errorBundlePretty) +import Text.RawString.QQ (r) + +petSchema :: Schema IO +petSchema = schema queryType Nothing (Just subscriptionType) mempty + +queryType :: ObjectType IO +queryType = ObjectType "Query" Nothing [] $ HashMap.fromList + [ ("dog", dogResolver) + , ("cat", catResolver) + , ("findDog", findDogResolver) + ] + where + dogField = Field Nothing (Out.NamedObjectType dogType) mempty + dogResolver = ValueResolver dogField $ pure Null + findDogArguments = HashMap.singleton "complex" + $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing + findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments + findDogResolver = ValueResolver findDogField $ pure Null + catField = Field Nothing (Out.NamedObjectType catType) mempty + catResolver = ValueResolver catField $ pure Null + +catCommandType :: EnumType +catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList + [ ("JUMP", EnumValue Nothing) + ] + +catType :: ObjectType IO +catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList + [ ("name", nameResolver) + , ("nickname", nicknameResolver) + , ("doesKnowCommand", doesKnowCommandResolver) + , ("meowVolume", meowVolumeResolver) + ] + where + meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty + meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3 + doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "catCommand" + $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing + doesKnowCommandResolver = ValueResolver doesKnowCommandField + $ pure $ Boolean True + +nameResolver :: Resolver IO +nameResolver = ValueResolver nameField $ pure "Name" + where + nameField = Field Nothing (Out.NonNullScalarType string) mempty + +nicknameResolver :: Resolver IO +nicknameResolver = ValueResolver nicknameField $ pure "Nickname" + where + nicknameField = Field Nothing (Out.NamedScalarType string) mempty + +dogCommandType :: EnumType +dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList + [ ("SIT", EnumValue Nothing) + , ("DOWN", EnumValue Nothing) + , ("HEEL", EnumValue Nothing) + ] + +dogType :: ObjectType IO +dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList + [ ("name", nameResolver) + , ("nickname", nicknameResolver) + , ("barkVolume", barkVolumeResolver) + , ("doesKnowCommand", doesKnowCommandResolver) + , ("isHousetrained", isHousetrainedResolver) + , ("owner", ownerResolver) + ] + where + barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty + barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3 + doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "dogCommand" + $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing + doesKnowCommandResolver = ValueResolver doesKnowCommandField + $ pure $ Boolean True + isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "atOtherHomes" + $ In.Argument Nothing (In.NamedScalarType boolean) Nothing + isHousetrainedResolver = ValueResolver isHousetrainedField + $ pure $ Boolean True + ownerField = Field Nothing (Out.NamedObjectType humanType) mempty + ownerResolver = ValueResolver ownerField $ pure Null + +dogDataType :: InputObjectType +dogDataType = InputObjectType "DogData" Nothing + $ HashMap.singleton "name" nameInputField + where + nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing + +sentientType :: InterfaceType IO +sentientType = InterfaceType "Sentient" Nothing [] + $ HashMap.singleton "name" + $ Field Nothing (Out.NonNullScalarType string) mempty + +petType :: InterfaceType IO +petType = InterfaceType "Pet" Nothing [] + $ HashMap.singleton "name" + $ Field Nothing (Out.NonNullScalarType string) mempty + +subscriptionType :: ObjectType IO +subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList + [ ("newMessage", newMessageResolver) + , ("disallowedSecondRootField", newMessageResolver) + ] + where + newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty + newMessageResolver = ValueResolver newMessageField + $ pure $ Object HashMap.empty + +messageType :: ObjectType IO +messageType = ObjectType "Message" Nothing [] $ HashMap.fromList + [ ("sender", senderResolver) + , ("body", bodyResolver) + ] + where + senderField = Field Nothing (Out.NonNullScalarType string) mempty + senderResolver = ValueResolver senderField $ pure "Sender" + bodyField = Field Nothing (Out.NonNullScalarType string) mempty + bodyResolver = ValueResolver bodyField $ pure "Message body." + +humanType :: ObjectType IO +humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList + [ ("name", nameResolver) + , ("pets", petsResolver) + ] + where + petsField = + Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty + petsResolver = ValueResolver petsField $ pure $ List [] + +validate :: Text -> [Error] +validate queryString = + case parse AST.document "" queryString of + Left parseErrors -> error $ errorBundlePretty parseErrors + Right ast -> toList $ document petSchema specifiedRules ast + +spec :: Spec +spec = + describe "document" $ do + context "executableDefinitionsRule" $ + it "rejects type definitions" $ + let queryString = [r| + query getDogName { + dog { + name + color + } + } + + extend type Dog { + color: String + } + |] + expected = Error + { message = + "Definition must be OperationDefinition or \ + \FragmentDefinition." + , locations = [AST.Location 9 19] + } + in validate queryString `shouldContain` [expected] + + context "singleFieldSubscriptionsRule" $ do + it "rejects multiple subscription root fields" $ + let queryString = [r| + subscription sub { + newMessage { + body + sender + } + disallowedSecondRootField + } + |] + expected = Error + { message = + "Subscription \"sub\" must select only one top \ + \level field." + , locations = [AST.Location 2 19] + } + in validate queryString `shouldContain` [expected] + + it "rejects multiple subscription root fields coming from a fragment" $ + let queryString = [r| + subscription sub { + ...multipleSubscriptions + } + + fragment multipleSubscriptions on Subscription { + newMessage { + body + sender + } + disallowedSecondRootField + } + |] + expected = Error + { message = + "Subscription \"sub\" must select only one top \ + \level field." + , locations = [AST.Location 2 19] + } + in validate queryString `shouldContain` [expected] + + it "finds corresponding subscription fragment" $ + let queryString = [r| + subscription sub { + ...anotherSubscription + ...multipleSubscriptions + } + fragment multipleSubscriptions on Subscription { + newMessage { + body + } + disallowedSecondRootField { + sender + } + } + fragment anotherSubscription on Subscription { + newMessage { + body + sender + } + } + |] + expected = Error + { message = + "Subscription \"sub\" must select only one top \ + \level field." + , locations = [AST.Location 2 19] + } + in validate queryString `shouldBe` [expected] + + context "loneAnonymousOperationRule" $ + it "rejects multiple anonymous operations" $ + let queryString = [r| + { + dog { + name + } + } + + query getName { + dog { + owner { + name + } + } + } + |] + expected = Error + { message = + "This anonymous operation must be the only defined \ + \operation." + , locations = [AST.Location 2 19] + } + in validate queryString `shouldBe` [expected] + + context "uniqueOperationNamesRule" $ + it "rejects operations with the same name" $ + let queryString = [r| + query dogOperation { + dog { + name + } + } + + mutation dogOperation { + mutateDog { + id + } + } + |] + expected = Error + { message = + "There can be only one operation named \ + \\"dogOperation\"." + , locations = [AST.Location 2 19, AST.Location 8 19] + } + in validate queryString `shouldBe` [expected] + + context "uniqueFragmentNamesRule" $ + it "rejects fragments with the same name" $ + let queryString = [r| + { + dog { + ...fragmentOne + } + } + + fragment fragmentOne on Dog { + name + } + + fragment fragmentOne on Dog { + owner { + name + } + } + |] + expected = Error + { message = + "There can be only one fragment named \ + \\"fragmentOne\"." + , locations = [AST.Location 8 19, AST.Location 12 19] + } + in validate queryString `shouldBe` [expected] + + context "fragmentSpreadTargetDefinedRule" $ + it "rejects the fragment spread without a target" $ + let queryString = [r| + { + dog { + ...undefinedFragment + } + } + |] + expected = Error + { message = + "Fragment target \"undefinedFragment\" is \ + \undefined." + , locations = [AST.Location 4 23] + } + in validate queryString `shouldBe` [expected] + + context "fragmentSpreadTypeExistenceRule" $ do + it "rejects fragment spreads without an unknown target type" $ + let queryString = [r| + { + dog { + ...notOnExistingType + } + } + fragment notOnExistingType on NotInSchema { + name + } + |] + expected = Error + { message = + "Fragment \"notOnExistingType\" is specified on \ + \type \"NotInSchema\" which doesn't exist in the \ + \schema." + , locations = [AST.Location 4 23] + } + in validate queryString `shouldBe` [expected] + + it "rejects inline fragments without a target" $ + let queryString = [r| + { + ... on NotInSchema { + name + } + } + |] + expected = Error + { message = + "Inline fragment is specified on type \ + \\"NotInSchema\" which doesn't exist in the schema." + , locations = [AST.Location 3 21] + } + in validate queryString `shouldBe` [expected] + + context "fragmentsOnCompositeTypesRule" $ do + it "rejects fragments on scalar types" $ + let queryString = [r| + { + dog { + ...fragOnScalar + } + } + fragment fragOnScalar on Int { + name + } + |] + expected = Error + { message = + "Fragment cannot condition on non composite type \ + \\"Int\"." + , locations = [AST.Location 7 19] + } + in validate queryString `shouldContain` [expected] + + it "rejects inline fragments on scalar types" $ + let queryString = [r| + { + ... on Boolean { + name + } + } + |] + expected = Error + { message = + "Fragment cannot condition on non composite type \ + \\"Boolean\"." + , locations = [AST.Location 3 21] + } + in validate queryString `shouldContain` [expected] + + context "noUnusedFragmentsRule" $ + it "rejects unused fragments" $ + let queryString = [r| + fragment nameFragment on Dog { # unused + name + } + + { + dog { + name + } + } + |] + expected = Error + { message = + "Fragment \"nameFragment\" is never used." + , locations = [AST.Location 2 19] + } + in validate queryString `shouldBe` [expected] + + context "noFragmentCyclesRule" $ + it "rejects spreads that form cycles" $ + let queryString = [r| + { + dog { + ...nameFragment + } + } + fragment nameFragment on Dog { + name + ...barkVolumeFragment + } + fragment barkVolumeFragment on Dog { + barkVolume + ...nameFragment + } + |] + error1 = Error + { message = + "Cannot spread fragment \"barkVolumeFragment\" \ + \within itself (via barkVolumeFragment -> \ + \nameFragment -> barkVolumeFragment)." + , locations = [AST.Location 11 19] + } + error2 = Error + { message = + "Cannot spread fragment \"nameFragment\" within \ + \itself (via nameFragment -> barkVolumeFragment -> \ + \nameFragment)." + , locations = [AST.Location 7 19] + } + in validate queryString `shouldBe` [error1, error2] + + context "uniqueArgumentNamesRule" $ + it "rejects duplicate field arguments" $ + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: true, atOtherHomes: true) + } + } + |] + expected = Error + { message = + "There can be only one argument named \ + \\"atOtherHomes\"." + , locations = [AST.Location 4 38, AST.Location 4 58] + } + in validate queryString `shouldBe` [expected] + + context "uniqueDirectiveNamesRule" $ + it "rejects more than one directive per location" $ + let queryString = [r| + query ($foo: Boolean = true, $bar: Boolean = false) { + dog @skip(if: $foo) @skip(if: $bar) { + name + } + } + |] + expected = Error + { message = + "There can be only one directive named \"skip\"." + , locations = [AST.Location 3 25, AST.Location 3 41] + } + in validate queryString `shouldBe` [expected] + + context "uniqueVariableNamesRule" $ + it "rejects duplicate variables" $ + let queryString = [r| + query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) { + dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + } + |] + expected = Error + { message = + "There can be only one variable named \ + \\"atOtherHomes\"." + , locations = [AST.Location 2 43, AST.Location 2 67] + } + in validate queryString `shouldBe` [expected] + + context "variablesAreInputTypesRule" $ + it "rejects non-input types as variables" $ + let queryString = [r| + query takesDogBang($dog: Dog!) { + dog { + isHousetrained(atOtherHomes: $dog) + } + } + |] + expected = Error + { message = + "Variable \"$dog\" cannot be non-input type \ + \\"Dog\"." + , locations = [AST.Location 2 38] + } + in validate queryString `shouldContain` [expected] + + context "noUndefinedVariablesRule" $ + it "rejects undefined variables" $ + let queryString = [r| + query variableIsNotDefinedUsedInSingleFragment { + dog { + ...isHousetrainedFragment + } + } + + fragment isHousetrainedFragment on Dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + |] + expected = Error + { message = + "Variable \"$atOtherHomes\" is not defined by \ + \operation \ + \\"variableIsNotDefinedUsedInSingleFragment\"." + , locations = [AST.Location 9 50] + } + in validate queryString `shouldBe` [expected] + + context "noUnusedVariablesRule" $ + it "rejects unused variables" $ + let queryString = [r| + query variableUnused($atOtherHomes: Boolean) { + dog { + isHousetrained + } + } + |] + expected = Error + { message = + "Variable \"$atOtherHomes\" is never used in \ + \operation \"variableUnused\"." + , locations = [AST.Location 2 40] + } + in validate queryString `shouldBe` [expected] + + context "uniqueInputFieldNamesRule" $ + it "rejects duplicate fields in input objects" $ + let queryString = [r| + { + findDog(complex: { name: "Fido", name: "Jack" }) { + name + } + } + |] + expected = Error + { message = + "There can be only one input field named \"name\"." + , locations = [AST.Location 3 40, AST.Location 3 54] + } + in validate queryString `shouldBe` [expected] + + context "fieldsOnCorrectTypeRule" $ + it "rejects undefined fields" $ + let queryString = [r| + { + dog { + meowVolume + } + } + |] + expected = Error + { message = + "Cannot query field \"meowVolume\" on type \"Dog\"." + , locations = [AST.Location 4 23] + } + in validate queryString `shouldBe` [expected] + + context "scalarLeafsRule" $ + it "rejects scalar fields with not empty selection set" $ + let queryString = [r| + { + dog { + barkVolume { + sinceWhen + } + } + } + |] + expected = Error + { message = + "Field \"barkVolume\" must not have a selection \ + \since type \"Int\" has no subfields." + , locations = [AST.Location 4 23] + } + in validate queryString `shouldBe` [expected] + + context "knownArgumentNamesRule" $ do + it "rejects field arguments missing in the type" $ + let queryString = [r| + { + dog { + doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT) + } + } + |] + expected = Error + { message = + "Unknown argument \"command\" on field \ + \\"Dog.doesKnowCommand\"." + , locations = [AST.Location 4 39] + } + in validate queryString `shouldBe` [expected] + + it "rejects directive arguments missing in the definition" $ + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: true) @include(unless: false, if: true) + } + } + |] + expected = Error + { message = + "Unknown argument \"unless\" on directive \ + \\"@include\"." + , locations = [AST.Location 4 67] + } + in validate queryString `shouldBe` [expected] + + context "knownDirectiveNamesRule" $ + it "rejects undefined directives" $ + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: true) @ignore(if: true) + } + } + |] + expected = Error + { message = "Unknown directive \"@ignore\"." + , locations = [AST.Location 4 58] + } + in validate queryString `shouldBe` [expected] + + context "knownInputFieldNamesRule" $ + it "rejects undefined input object fields" $ + let queryString = [r| + { + findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) { + name + } + } + |] + expected = Error + { message = + "Field \"favoriteCookieFlavor\" is not defined \ + \by type \"DogData\"." + , locations = [AST.Location 3 40] + } + in validate queryString `shouldBe` [expected] + + context "directivesInValidLocationsRule" $ + it "rejects directives in invalid locations" $ + let queryString = [r| + query @skip(if: $foo) { + dog { + name + } + } + |] + expected = Error + { message = + "Directive \"@skip\" may not be used on QUERY." + , locations = [AST.Location 2 25] + } + in validate queryString `shouldBe` [expected] + + context "overlappingFieldsCanBeMergedRule" $ do + it "fails to merge fields of mismatching types" $ + let queryString = [r| + { + dog { + name: nickname + name + } + } + |] + expected = Error + { message = + "Fields \"name\" conflict because \"nickname\" and \ + \\"name\" are different fields. Use different \ + \aliases on the fields to fetch both if this was \ + \intentional." + , locations = [AST.Location 4 23, AST.Location 5 23] + } + in validate queryString `shouldBe` [expected] + + it "fails if the arguments of the same field don't match" $ + let queryString = [r| + { + dog { + doesKnowCommand(dogCommand: SIT) + doesKnowCommand(dogCommand: HEEL) + } + } + |] + expected = Error + { message = + "Fields \"doesKnowCommand\" conflict because they \ + \have different arguments. Use different aliases \ + \on the fields to fetch both if this was \ + \intentional." + , locations = [AST.Location 4 23, AST.Location 5 23] + } + in validate queryString `shouldBe` [expected] + + it "fails to merge same-named field and alias" $ + let queryString = [r| + { + dog { + doesKnowCommand(dogCommand: SIT) + doesKnowCommand: isHousetrained(atOtherHomes: true) + } + } + |] + expected = Error + { message = + "Fields \"doesKnowCommand\" conflict because \ + \\"doesKnowCommand\" and \"isHousetrained\" are \ + \different fields. Use different aliases on the \ + \fields to fetch both if this was intentional." + , locations = [AST.Location 4 23, AST.Location 5 23] + } + in validate queryString `shouldBe` [expected] + + it "looks for fields after a successfully merged field pair" $ + let queryString = [r| + { + dog { + name + doesKnowCommand(dogCommand: SIT) + } + dog { + name + doesKnowCommand: isHousetrained(atOtherHomes: true) + } + } + |] + expected = Error + { message = + "Fields \"doesKnowCommand\" conflict because \ + \\"doesKnowCommand\" and \"isHousetrained\" are \ + \different fields. Use different aliases on the \ + \fields to fetch both if this was intentional." + , locations = [AST.Location 5 23, AST.Location 9 23] + } + in validate queryString `shouldBe` [expected] + + context "possibleFragmentSpreadsRule" $ do + it "rejects object inline spreads outside object scope" $ + let queryString = [r| + { + dog { + ... on Cat { + meowVolume + } + } + } + |] + expected = Error + { message = + "Fragment cannot be spread here as objects of type \ + \\"Dog\" can never be of type \"Cat\"." + , locations = [AST.Location 4 23] + } + in validate queryString `shouldBe` [expected] + + it "rejects object named spreads outside object scope" $ + let queryString = [r| + { + dog { + ... catInDogFragmentInvalid + } + } + + fragment catInDogFragmentInvalid on Cat { + meowVolume + } + |] + expected = Error + { message = + "Fragment \"catInDogFragmentInvalid\" cannot be \ + \spread here as objects of type \"Dog\" can never \ + \be of type \"Cat\"." + , locations = [AST.Location 4 23] + } + in validate queryString `shouldBe` [expected] + + context "providedRequiredInputFieldsRule" $ + it "rejects missing required input fields" $ + let queryString = [r| + { + findDog(complex: { name: null }) { + name + } + } + |] + expected = Error + { message = + "Input field \"name\" of type \"DogData\" is \ + \required, but it was not provided." + , locations = [AST.Location 3 38] + } + in validate queryString `shouldBe` [expected] + + context "providedRequiredArgumentsRule" $ + 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 23] + } + in validate queryString `shouldBe` [expected] + + context "variablesInAllowedPositionRule" $ do + it "rejects wrongly typed variable arguments" $ + let queryString = [r| + query catCommandArgQuery($catCommandArg: CatCommand) { + cat { + doesKnowCommand(catCommand: $catCommandArg) + } + } + |] + expected = Error + { message = + "Variable \"$catCommandArg\" of type \ + \\"CatCommand\" used in position expecting type \ + \\"!CatCommand\"." + , locations = [AST.Location 2 44] + } + in validate queryString `shouldBe` [expected] + + it "rejects wrongly typed variable arguments" $ + let queryString = [r| + query intCannotGoIntoBoolean($intArg: Int) { + dog { + isHousetrained(atOtherHomes: $intArg) + } + } + |] + expected = Error + { message = + "Variable \"$intArg\" of type \"Int\" used in \ + \position expecting type \"Boolean\"." + , locations = [AST.Location 2 48] + } + in validate queryString `shouldBe` [expected] + + context "valuesOfCorrectTypeRule" $ + it "rejects values of incorrect types" $ + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: 3) + } + } + |] + expected = Error + { message = + "Value 3 cannot be coerced to type \"Boolean\"." + , locations = [AST.Location 4 52] + } + in validate queryString `shouldBe` [expected] diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs deleted file mode 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ /dev/null @@ -1,665 +0,0 @@ -{- 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 OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Language.GraphQL.ValidateSpec - ( spec - ) where - -import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) -import qualified Language.GraphQL.AST as AST -import Language.GraphQL.Type -import qualified Language.GraphQL.Type.In as In -import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Validate -import Test.Hspec (Spec, describe, it, shouldBe, shouldContain) -import Text.Megaparsec (parse) -import Text.RawString.QQ (r) - -petSchema :: Schema IO -petSchema = schema queryType Nothing (Just subscriptionType) mempty - -queryType :: ObjectType IO -queryType = ObjectType "Query" Nothing [] $ HashMap.fromList - [ ("dog", dogResolver) - , ("findDog", findDogResolver) - ] - where - dogField = Field Nothing (Out.NamedObjectType dogType) mempty - dogResolver = ValueResolver dogField $ pure Null - findDogArguments = HashMap.singleton "complex" - $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing - findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments - findDogResolver = ValueResolver findDogField $ pure Null - -dogCommandType :: EnumType -dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList - [ ("SIT", EnumValue Nothing) - , ("DOWN", EnumValue Nothing) - , ("HEEL", EnumValue Nothing) - ] - -dogType :: ObjectType IO -dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList - [ ("name", nameResolver) - , ("nickname", nicknameResolver) - , ("barkVolume", barkVolumeResolver) - , ("doesKnowCommand", doesKnowCommandResolver) - , ("isHousetrained", isHousetrainedResolver) - , ("owner", ownerResolver) - ] - where - nameField = Field Nothing (Out.NonNullScalarType string) mempty - nameResolver = ValueResolver nameField $ pure "Name" - nicknameField = Field Nothing (Out.NamedScalarType string) mempty - nicknameResolver = ValueResolver nicknameField $ pure "Nickname" - barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty - barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3 - doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean) - $ HashMap.singleton "dogCommand" - $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing - doesKnowCommandResolver = ValueResolver doesKnowCommandField - $ pure $ Boolean True - isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean) - $ HashMap.singleton "atOtherHomes" - $ In.Argument Nothing (In.NamedScalarType boolean) Nothing - isHousetrainedResolver = ValueResolver isHousetrainedField - $ pure $ Boolean True - ownerField = Field Nothing (Out.NamedObjectType humanType) mempty - ownerResolver = ValueResolver ownerField $ pure Null - -dogDataType :: InputObjectType -dogDataType = InputObjectType "DogData" Nothing - $ HashMap.singleton "name" nameInputField - where - nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing - -sentientType :: InterfaceType IO -sentientType = InterfaceType "Sentient" Nothing [] - $ HashMap.singleton "name" - $ Field Nothing (Out.NonNullScalarType string) mempty - -petType :: InterfaceType IO -petType = InterfaceType "Pet" Nothing [] - $ HashMap.singleton "name" - $ Field Nothing (Out.NonNullScalarType string) mempty - -subscriptionType :: ObjectType IO -subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList - [ ("newMessage", newMessageResolver) - , ("disallowedSecondRootField", newMessageResolver) - ] - where - newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty - newMessageResolver = ValueResolver newMessageField - $ pure $ Object HashMap.empty - -messageType :: ObjectType IO -messageType = ObjectType "Message" Nothing [] $ HashMap.fromList - [ ("sender", senderResolver) - , ("body", bodyResolver) - ] - where - senderField = Field Nothing (Out.NonNullScalarType string) mempty - senderResolver = ValueResolver senderField $ pure "Sender" - bodyField = Field Nothing (Out.NonNullScalarType string) mempty - bodyResolver = ValueResolver bodyField $ pure "Message body." - -humanType :: ObjectType IO -humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList - [ ("name", nameResolver) - , ("pets", petsResolver) - ] - where - nameField = Field Nothing (Out.NonNullScalarType string) mempty - nameResolver = ValueResolver nameField $ pure "Name" - petsField = - Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty - petsResolver = ValueResolver petsField $ pure $ List [] -{- -catOrDogType :: UnionType IO -catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType] --} -validate :: Text -> [Error] -validate queryString = - case parse AST.document "" queryString of - Left _ -> [] - Right ast -> toList $ document petSchema specifiedRules ast - -spec :: Spec -spec = - describe "document" $ do - it "rejects type definitions" $ - let queryString = [r| - query getDogName { - dog { - name - color - } - } - - extend type Dog { - color: String - } - |] - expected = Error - { message = - "Definition must be OperationDefinition or FragmentDefinition." - , locations = [AST.Location 9 15] - } - in validate queryString `shouldContain` [expected] - - it "rejects multiple subscription root fields" $ - let queryString = [r| - subscription sub { - newMessage { - body - sender - } - disallowedSecondRootField - } - |] - expected = Error - { message = - "Subscription \"sub\" must select only one top level \ - \field." - , locations = [AST.Location 2 15] - } - in validate queryString `shouldContain` [expected] - - it "rejects multiple subscription root fields coming from a fragment" $ - let queryString = [r| - subscription sub { - ...multipleSubscriptions - } - - fragment multipleSubscriptions on Subscription { - newMessage { - body - sender - } - disallowedSecondRootField - } - |] - expected = Error - { message = - "Subscription \"sub\" must select only one top level \ - \field." - , locations = [AST.Location 2 15] - } - in validate queryString `shouldContain` [expected] - - it "rejects multiple anonymous operations" $ - let queryString = [r| - { - dog { - name - } - } - - query getName { - dog { - owner { - name - } - } - } - |] - expected = Error - { message = - "This anonymous operation must be the only defined operation." - , locations = [AST.Location 2 15] - } - in validate queryString `shouldBe` [expected] - - it "rejects operations with the same name" $ - let queryString = [r| - query dogOperation { - dog { - name - } - } - - mutation dogOperation { - mutateDog { - id - } - } - |] - expected = Error - { message = - "There can be only one operation named \"dogOperation\"." - , locations = [AST.Location 2 15, AST.Location 8 15] - } - in validate queryString `shouldBe` [expected] - - it "rejects fragments with the same name" $ - let queryString = [r| - { - dog { - ...fragmentOne - } - } - - fragment fragmentOne on Dog { - name - } - - fragment fragmentOne on Dog { - owner { - name - } - } - |] - expected = Error - { message = - "There can be only one fragment named \"fragmentOne\"." - , locations = [AST.Location 8 15, AST.Location 12 15] - } - in validate queryString `shouldBe` [expected] - - it "rejects the fragment spread without a target" $ - let queryString = [r| - { - dog { - ...undefinedFragment - } - } - |] - expected = Error - { message = - "Fragment target \"undefinedFragment\" is undefined." - , locations = [AST.Location 4 19] - } - in validate queryString `shouldBe` [expected] - - it "rejects fragment spreads without an unknown target type" $ - let queryString = [r| - { - dog { - ...notOnExistingType - } - } - fragment notOnExistingType on NotInSchema { - name - } - |] - expected = Error - { message = - "Fragment \"notOnExistingType\" is specified on type \ - \\"NotInSchema\" which doesn't exist in the schema." - , locations = [AST.Location 4 19] - } - in validate queryString `shouldBe` [expected] - - it "rejects inline fragments without a target" $ - let queryString = [r| - { - ... on NotInSchema { - name - } - } - |] - expected = Error - { message = - "Inline fragment is specified on type \"NotInSchema\" \ - \which doesn't exist in the schema." - , locations = [AST.Location 3 17] - } - in validate queryString `shouldBe` [expected] - - it "rejects fragments on scalar types" $ - let queryString = [r| - { - dog { - ...fragOnScalar - } - } - fragment fragOnScalar on Int { - name - } - |] - expected = Error - { message = - "Fragment cannot condition on non composite type \ - \\"Int\"." - , locations = [AST.Location 7 15] - } - in validate queryString `shouldContain` [expected] - - it "rejects inline fragments on scalar types" $ - let queryString = [r| - { - ... on Boolean { - name - } - } - |] - expected = Error - { message = - "Fragment cannot condition on non composite type \ - \\"Boolean\"." - , locations = [AST.Location 3 17] - } - in validate queryString `shouldContain` [expected] - - it "rejects unused fragments" $ - let queryString = [r| - fragment nameFragment on Dog { # unused - name - } - - { - dog { - name - } - } - |] - expected = Error - { message = - "Fragment \"nameFragment\" is never used." - , locations = [AST.Location 2 15] - } - in validate queryString `shouldBe` [expected] - - it "rejects spreads that form cycles" $ - let queryString = [r| - { - dog { - ...nameFragment - } - } - fragment nameFragment on Dog { - name - ...barkVolumeFragment - } - fragment barkVolumeFragment on Dog { - barkVolume - ...nameFragment - } - |] - error1 = Error - { message = - "Cannot spread fragment \"barkVolumeFragment\" within \ - \itself (via barkVolumeFragment -> nameFragment -> \ - \barkVolumeFragment)." - , locations = [AST.Location 11 15] - } - error2 = Error - { message = - "Cannot spread fragment \"nameFragment\" within itself \ - \(via nameFragment -> barkVolumeFragment -> \ - \nameFragment)." - , locations = [AST.Location 7 15] - } - in validate queryString `shouldBe` [error1, error2] - - it "rejects duplicate field arguments" $ do - let queryString = [r| - { - dog { - isHousetrained(atOtherHomes: true, atOtherHomes: true) - } - } - |] - expected = Error - { message = - "There can be only one argument named \"atOtherHomes\"." - , locations = [AST.Location 4 34, AST.Location 4 54] - } - in validate queryString `shouldBe` [expected] - - it "rejects more than one directive per location" $ do - let queryString = [r| - query ($foo: Boolean = true, $bar: Boolean = false) { - dog @skip(if: $foo) @skip(if: $bar) { - name - } - } - |] - expected = Error - { message = - "There can be only one directive named \"skip\"." - , locations = [AST.Location 3 21, AST.Location 3 37] - } - in validate queryString `shouldBe` [expected] - - it "rejects duplicate variables" $ - let queryString = [r| - query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) { - dog { - isHousetrained(atOtherHomes: $atOtherHomes) - } - } - |] - expected = Error - { message = - "There can be only one variable named \"atOtherHomes\"." - , locations = [AST.Location 2 39, AST.Location 2 63] - } - in validate queryString `shouldBe` [expected] - - it "rejects non-input types as variables" $ - let queryString = [r| - query takesDogBang($dog: Dog!) { - dog { - isHousetrained(atOtherHomes: $dog) - } - } - |] - expected = Error - { message = - "Variable \"$dog\" cannot be non-input type \"Dog\"." - , locations = [AST.Location 2 34] - } - in validate queryString `shouldBe` [expected] - - it "rejects undefined variables" $ - let queryString = [r| - query variableIsNotDefinedUsedInSingleFragment { - dog { - ...isHousetrainedFragment - } - } - - fragment isHousetrainedFragment on Dog { - isHousetrained(atOtherHomes: $atOtherHomes) - } - |] - expected = Error - { message = - "Variable \"$atOtherHomes\" is not defined by \ - \operation \ - \\"variableIsNotDefinedUsedInSingleFragment\"." - , locations = [AST.Location 9 46] - } - in validate queryString `shouldBe` [expected] - - it "rejects unused variables" $ - let queryString = [r| - query variableUnused($atOtherHomes: Boolean) { - dog { - isHousetrained - } - } - |] - expected = Error - { message = - "Variable \"$atOtherHomes\" is never used in operation \ - \\"variableUnused\"." - , locations = [AST.Location 2 36] - } - in validate queryString `shouldBe` [expected] - - it "rejects duplicate fields in input objects" $ - let queryString = [r| - { - findDog(complex: { name: "Fido", name: "Jack" }) { - name - } - } - |] - expected = Error - { message = - "There can be only one input field named \"name\"." - , locations = [AST.Location 3 36, AST.Location 3 50] - } - in validate queryString `shouldBe` [expected] - - it "rejects undefined fields" $ - let queryString = [r| - { - dog { - meowVolume - } - } - |] - expected = Error - { message = - "Cannot query field \"meowVolume\" on type \"Dog\"." - , locations = [AST.Location 4 19] - } - in validate queryString `shouldBe` [expected] - - it "rejects scalar fields with not empty selection set" $ - let queryString = [r| - { - dog { - barkVolume { - sinceWhen - } - } - } - |] - expected = Error - { message = - "Field \"barkVolume\" must not have a selection since \ - \type \"Int\" has no subfields." - , locations = [AST.Location 4 19] - } - in validate queryString `shouldBe` [expected] - - it "rejects field arguments missing in the type" $ - let queryString = [r| - { - dog { - doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT) - } - } - |] - expected = Error - { message = - "Unknown argument \"command\" on field \ - \\"Dog.doesKnowCommand\"." - , locations = [AST.Location 4 35] - } - in validate queryString `shouldBe` [expected] - - it "rejects directive arguments missing in the definition" $ - let queryString = [r| - { - dog { - isHousetrained(atOtherHomes: true) @include(unless: false, if: true) - } - } - |] - expected = Error - { message = - "Unknown argument \"unless\" on directive \"@include\"." - , locations = [AST.Location 4 63] - } - in validate queryString `shouldBe` [expected] - - it "rejects undefined directives" $ - let queryString = [r| - { - dog { - isHousetrained(atOtherHomes: true) @ignore(if: true) - } - } - |] - expected = Error - { message = "Unknown directive \"@ignore\"." - , locations = [AST.Location 4 54] - } - in validate queryString `shouldBe` [expected] - - it "rejects undefined input object fields" $ - let queryString = [r| - { - findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) { - name - } - } - |] - expected = Error - { message = - "Field \"favoriteCookieFlavor\" is not defined \ - \by type \"DogData\"." - , locations = [AST.Location 3 36] - } - in validate queryString `shouldBe` [expected] - - it "rejects directives in invalid locations" $ - let queryString = [r| - query @skip(if: $foo) { - dog { - name - } - } - |] - expected = Error - { message = "Directive \"@skip\" may not be used on QUERY." - , locations = [AST.Location 2 21] - } - in validate queryString `shouldBe` [expected] - - it "rejects missing required input fields" $ - let queryString = [r| - { - findDog(complex: { name: null }) { - name - } - } - |] - expected = Error - { message = - "Input field \"name\" of type \"DogData\" is required, \ - \but it was not provided." - , locations = [AST.Location 3 34] - } - in validate queryString `shouldBe` [expected] - - it "finds corresponding subscription fragment" $ - let queryString = [r| - subscription sub { - ...anotherSubscription - ...multipleSubscriptions - } - fragment multipleSubscriptions on Subscription { - newMessage { - body - } - disallowedSecondRootField { - sender - } - } - fragment anotherSubscription on Subscription { - newMessage { - body - sender - } - } - |] - expected = Error - { message = - "Subscription \"sub\" must select only one top level \ - \field." - , locations = [AST.Location 2 15] - } - in validate queryString `shouldBe` [expected]