diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,37 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.5.0.2] - 2026-01-08 +### Fixed +- Support GHC 9.14 and containers 0.8. + +## [1.5.0.1] - 2025-06-19 +### Fixed +- Allow any 2.x QuickCheck version. +- Make the lexer and parser safe. + +## [1.5.0.0] - 2024-12-03 +### Removed +- Remove deprecated 'gql' quasi quoter. + +### Changed +- Validate the subscription root not to be an introspection field + (`singleFieldSubscriptionsRule`). + +## [1.4.0.0] - 2024-10-26 +### Changed +- `Schema.Directive` is extended to contain a boolean argument, representing + repeatable directives. The parser can parse repeatable directive definitions. + Validation allows repeatable directives. +- `AST.Document.Directive` is a record. +- `gql` quasi quoter is deprecated (moved to graphql-spice package). + +### Fixed +- `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF). + +### Added +- @specifiedBy directive. + ## [1.3.0.0] - 2024-05-01 ### Changed - Remove deprecated `runCollectErrs`, `Resolution`, `CollectErrsT` from the @@ -524,6 +555,10 @@ ### Added - Data types for the GraphQL language. +[1.5.0.2]: https://git.caraus.tech/OSS/graphql/compare/v1.5.0.1...v1.5.0.2 +[1.5.0.1]: https://git.caraus.tech/OSS/graphql/compare/v1.5.0.0...v1.5.0.1 +[1.5.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.4.0.0...v1.5.0.0 +[1.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.3.0.0...v1.4.0.0 [1.3.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.3...v1.3.0.0 [1.2.0.3]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.2...v1.2.0.3 [1.2.0.2]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...v1.2.0.2 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,11 +2,18 @@ See https://git.caraus.tech/OSS/graphql. +This is the core library that 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. + +## Documentation + Report issues on the [bug tracker](https://git.caraus.tech/OSS/graphql/issues). API documentation is available through [Hackage](https://hackage.haskell.org/package/graphql). - -Further documentation will be made available in the -[Wiki](https://git.caraus.tech/OSS/graphql/wiki). diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -1,28 +1,28 @@ -cabal-version: 2.4 +cabal-version: 3.0 -name: graphql -version: 1.3.0.0 -synopsis: Haskell GraphQL implementation -description: Haskell implementation. -category: Language -homepage: https://git.caraus.tech/OSS/graphql -bug-reports: https://git.caraus.tech/OSS/graphql/issues -author: Danny Navarro , - Matthías Páll Gissurarson , - Sólrún Halla Einarsdóttir -maintainer: belka@caraus.de -copyright: (c) 2019-2024 Eugen Wissner, - (c) 2015-2017 J. Daniel Navarro -license: MPL-2.0 AND BSD-3-Clause -license-files: LICENSE, - LICENSE.MPL -build-type: Simple +name: graphql +version: 1.5.0.2 +synopsis: Haskell GraphQL implementation +description: Haskell implementation. +category: Language +homepage: https://git.caraus.tech/OSS/graphql +bug-reports: https://issues.caraus.tech/projects/graphql/issues +author: Danny Navarro , + Matthías Páll Gissurarson , + Sólrún Halla Einarsdóttir +maintainer: belka@caraus.de +copyright: (c) 2019-2026 Eugen Wissner, + (c) 2015-2017 J. Daniel Navarro +license: MPL-2.0 AND BSD-3-Clause +license-files: LICENSE, + LICENSE.MPL +build-type: Simple extra-source-files: CHANGELOG.md README.md tested-with: - GHC == 9.4.7, - GHC == 9.6.3 + GHC == 9.12.2, + GHC == 9.14.1 source-repository head type: git @@ -41,7 +41,6 @@ Language.GraphQL.Execute Language.GraphQL.Execute.Coerce Language.GraphQL.Execute.OrderedMap - Language.GraphQL.TH Language.GraphQL.Type Language.GraphQL.Type.In Language.GraphQL.Type.Out @@ -58,13 +57,12 @@ ghc-options: -Wall build-depends: - base >= 4.7 && < 5, + base >= 4.15 && < 5, conduit ^>= 1.3.4, - containers >= 0.6 && < 0.8, + containers >= 0.6 && < 0.9, exceptions ^>= 0.10.4, megaparsec >= 9.0 && < 10, parser-combinators >= 1.3 && < 2, - template-haskell >= 2.16 && < 3, text >= 1.2 && < 3, transformers >= 0.5.6 && < 0.7, unordered-containers ^>= 0.2.14, @@ -93,7 +91,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: - QuickCheck >= 2.14 && < 2.16, + QuickCheck >= 2.14 && < 3, base, conduit, exceptions, diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | Target AST for parser. diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} --- | Various parts of a GraphQL document can be annotated with directives. +-- | Various parts of a GraphQL document can be annotated with directives. -- This module describes locations in a document where directives can appear. module Language.GraphQL.AST.DirectiveLocation ( DirectiveLocation(..) 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 @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | This module defines an abstract syntax tree for the @GraphQL@ language. It @@ -380,7 +381,11 @@ -- -- Directives begin with "@", can accept arguments, and can be applied to the -- most GraphQL elements, providing additional information. -data Directive = Directive Name [Argument] Location deriving (Eq, Show) +data Directive = Directive + { name :: Name + , arguments :: [Argument] + , location :: Location + } deriving (Eq, Show) -- * Type System @@ -405,7 +410,7 @@ = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition) | TypeDefinition TypeDefinition | DirectiveDefinition - Description Name ArgumentsDefinition (NonEmpty DirectiveLocation) + Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation) deriving (Eq, Show) -- ** Type System Extensions @@ -478,12 +483,9 @@ data TypeDefinition = ScalarTypeDefinition Description Name [Directive] | ObjectTypeDefinition - Description - Name - (ImplementsInterfaces []) - [Directive] - [FieldDefinition] - | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition] + Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition] + | InterfaceTypeDefinition + Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition] | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes []) | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition] | InputObjectTypeDefinition 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 @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | This module defines a minifier and a printer for the @GraphQL@ language. @@ -159,11 +160,12 @@ <> optempty (directives formatter) operationDirectives <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions') Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition' - Full.DirectiveDefinition description' name' arguments' locations + Full.DirectiveDefinition description' name' arguments' repeatable locations -> description formatter description' <> "@" <> Lazy.Text.fromStrict name' <> argumentsDefinition formatter arguments' + <> (if repeatable then " repeatable" else mempty) <> " on" <> pipeList formatter (directiveLocation <$> locations) @@ -225,10 +227,11 @@ <> optempty (directives formatter) directives' <> eitherFormat formatter " " "" <> bracesList formatter (fieldDefinition nextFormatter) fields' - Full.InterfaceTypeDefinition description' name' directives' fields' + Full.InterfaceTypeDefinition description' name' ifaces' directives' fields' -> optempty (description formatter) description' <> "interface " <> Lazy.Text.fromStrict name' + <> optempty (" " <>) (implementsInterfaces ifaces') <> optempty (directives formatter) directives' <> eitherFormat formatter " " "" <> bracesList formatter (fieldDefinition nextFormatter) fields' @@ -276,7 +279,7 @@ pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList pipeList (Pretty _) = Lazy.Text.concat . fmap (("\n" <> indentSymbol <> "| ") <>) - . toList + . toList enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text enumValueDefinition (Pretty _) enumValue = diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} -- | This module defines a bunch of small parsers used to parse individual -- lexemes. @@ -29,7 +31,8 @@ , unicodeBOM ) where -import Control.Applicative (Alternative(..), liftA2) +import Control.Applicative (Alternative(..)) +import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord) import Data.Foldable (foldl') import Data.List (dropWhileEnd) @@ -37,22 +40,22 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy (Proxy(..)) import Data.Void (Void) -import Text.Megaparsec ( Parsec - , () - , between - , chunk - , chunkToTokens - , notFollowedBy - , oneOf - , option - , optional - , satisfy - , sepBy - , skipSome - , takeP - , takeWhile1P - , try - ) +import Text.Megaparsec + ( Parsec + , () + , between + , chunk + , chunkToTokens + , notFollowedBy + , oneOf + , option + , optional + , satisfy + , skipSome + , takeP + , takeWhile1P + , try + ) import Text.Megaparsec.Char (char, digitChar, space1) import qualified Text.Megaparsec.Char.Lexer as Lexer import Data.Text (Text) @@ -142,12 +145,13 @@ blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer where stringValue = do - byLine <- sepBy (many blockStringCharacter) lineTerminator - let indentSize = foldr countIndent 0 $ tail byLine - withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine) + byLine <- NonEmpty.sepBy1 (many blockStringCharacter) lineTerminator + let indentSize = foldr countIndent 0 $ NonEmpty.tail byLine + withoutIndent = NonEmpty.head byLine + : (removeIndent indentSize <$> NonEmpty.tail byLine) withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent - return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines + pure $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines removeEmptyLine [] = True removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x) removeEmptyLine _ = False @@ -180,10 +184,10 @@ name = do firstLetter <- nameFirstLetter rest <- many $ nameFirstLetter <|> digitChar - _ <- spaceConsumer - return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest - where - nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_' + void spaceConsumer + pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest + where + nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_' isChunkDelimiter :: Char -> Bool isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r'] @@ -197,25 +201,25 @@ isSourceCharacter :: Char -> Bool isSourceCharacter = isSourceCharacter' . ord where - isSourceCharacter' code = code >= 0x0020 - || code == 0x0009 - || code == 0x000a - || code == 0x000d + isSourceCharacter' code + = code >= 0x0020 + || elem code [0x0009, 0x000a, 0x000d] escapeSequence :: Parser Char escapeSequence = do - _ <- char '\\' + void $ char '\\' escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u'] case escaped of - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'u' -> chr . foldl' step 0 - . chunkToTokens (Proxy :: Proxy T.Text) - <$> takeP Nothing 4 - _ -> return escaped + 'b' -> pure '\b' + 'f' -> pure '\f' + 'n' -> pure '\n' + 'r' -> pure '\r' + 't' -> pure '\t' + 'u' -> chr + . foldl' step 0 + . chunkToTokens (Proxy :: Proxy T.Text) + <$> takeP Nothing 4 + _ -> pure escaped where step accumulator = (accumulator * 16 +) . digitToInt diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -2,13 +2,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} -- | @GraphQL@ document parser. module Language.GraphQL.AST.Parser ( document ) where -import Control.Applicative (Alternative(..), liftA2, optional) +import Control.Applicative (Alternative(..), optional) import Control.Applicative.Combinators (sepBy1) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) @@ -27,6 +29,7 @@ , unPos , () ) +import Data.Maybe (isJust) -- | Parser for the GraphQL documents. document :: Parser Full.Document @@ -82,6 +85,7 @@ <* at <*> name <*> argumentsDefinition + <*> (isJust <$> optional (symbol "repeatable")) <* symbol "on" <*> directiveLocations "DirectiveDefinition" @@ -212,6 +216,7 @@ interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description' <$ symbol "interface" <*> name + <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> directives <*> braces (many fieldDefinition) "InterfaceTypeDefinition" diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -189,6 +189,8 @@ | CoercionError Full.VariableDefinition | UnknownInputType Full.VariableDefinition +type ExecuteHandler m a e = e -> ExecutorT m a + tell :: Monad m => Seq Error -> ExecutorT m () tell = ExecutorT . lift . Writer.tell @@ -313,8 +315,7 @@ pure $ Response data' errors handleException :: (MonadCatch m, Serialize a) - => FieldException - -> ExecutorT m a + => ExecuteHandler m a FieldException handleException (FieldException fieldLocation errorPath next) = let newError = constructError next fieldLocation errorPath in tell (Seq.singleton newError) >> pure null @@ -390,30 +391,28 @@ fieldErrorPath = fieldsSegment fields : errorPath inputCoercionHandler :: (MonadCatch m, Serialize a) => Full.Location - -> InputCoercionException - -> ExecutorT m a + -> ExecuteHandler m a InputCoercionException inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = let argumentLocation = getField @"location" valueNode in exceptionHandler argumentLocation e inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e resultHandler :: (MonadCatch m, Serialize a) => Full.Location - -> ResultException - -> ExecutorT m a + -> ExecuteHandler m a ResultException resultHandler = exceptionHandler resolverHandler :: (MonadCatch m, Serialize a) => Full.Location - -> ResolverException - -> ExecutorT m a + -> ExecuteHandler m a ResolverException resolverHandler = exceptionHandler - nullResultHandler :: (MonadCatch m, Serialize a) - => FieldException - -> ExecutorT m a + nullResultHandler :: (MonadCatch m, Serialize a) => ExecuteHandler m a FieldException nullResultHandler e@(FieldException fieldLocation errorPath' next) = let newError = constructError next fieldLocation errorPath' in if Out.isNonNullType fieldType then throwM e else returnError newError + exceptionHandler :: (Exception e, MonadCatch m, Serialize a) + => Full.Location + -> ExecuteHandler m a e exceptionHandler errorLocation e = let newError = constructError e errorLocation fieldErrorPath in if Out.isNonNullType fieldType diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -147,7 +147,7 @@ | member enumValue type' = Just $ Type.Enum enumValue where member value (Type.EnumType _ _ members) = HashMap.member value members -coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = let (In.InputObjectType _ _ inputFields) = type' in Type.Object <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs deleted file mode 100644 --- a/src/Language/GraphQL/TH.hs +++ /dev/null @@ -1,38 +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/. -} - --- | Template Haskell helpers. -module Language.GraphQL.TH - ( gql - ) where - -import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Language.Haskell.TH (Exp(..), Lit(..)) - -stripIndentation :: String -> String -stripIndentation code = reverse - $ dropNewlines - $ reverse - $ unlines - $ indent spaces <$> lines withoutLeadingNewlines - where - indent 0 xs = xs - indent count (' ' : xs) = indent (count - 1) xs - indent _ xs = xs - withoutLeadingNewlines = dropNewlines code - dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==) - spaces = length $ takeWhile (== ' ') withoutLeadingNewlines - --- | Removes leading and trailing newlines. Indentation of the first line is --- removed from each line of the string. -gql :: QuasiQuoter -gql = QuasiQuoter - { quoteExp = pure . LitE . StringL . stripIndentation - , quotePat = const - $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)" - , quoteType = const - $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)" - , quoteDec = const - $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)" - } 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 @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -- | Types that can be used as both input and output types. 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 @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} @@ -74,6 +75,7 @@ -- | Field argument definition. data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) + deriving Eq -- | Field argument definitions. type Arguments = HashMap Name Argument 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 @@ -48,7 +48,11 @@ deriving Eq -- | Directive definition. -data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments +-- +-- A definition consists of an optional description, arguments, whether the +-- directive is repeatable, and the allowed directive locations. +data Directive = Directive (Maybe Text) In.Arguments Bool [DirectiveLocation] + deriving Eq -- | Directive definitions. type Directives = HashMap Full.Name Directive 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 @@ -85,15 +85,16 @@ [ ("skip", skipDirective) , ("include", includeDirective) , ("deprecated", deprecatedDirective) + , ("specifiedBy", specifiedByDirective) ] includeDirective = - Directive includeDescription skipIncludeLocations includeArguments + Directive includeDescription includeArguments False skipIncludeLocations includeArguments = HashMap.singleton "if" $ In.Argument (Just "Included when true.") ifType Nothing includeDescription = Just "Directs the executor to include this field or fragment only when the \ \`if` argument is true." - skipDirective = Directive skipDescription skipIncludeLocations skipArguments + skipDirective = Directive skipDescription skipArguments False skipIncludeLocations skipArguments = HashMap.singleton "if" $ In.Argument (Just "skipped when true.") ifType Nothing ifType = In.NonNullScalarType Definition.boolean @@ -106,16 +107,15 @@ , ExecutableDirectiveLocation DirectiveLocation.InlineFragment ] deprecatedDirective = - Directive deprecatedDescription deprecatedLocations deprecatedArguments + Directive deprecatedDescription deprecatedArguments False deprecatedLocations reasonDescription = Just "Explains why this element was deprecated, usually also including a \ \suggestion for how to access supported similar data. Formatted using \ \the Markdown syntax, as specified by \ \[CommonMark](https://commonmark.org/).'" deprecatedArguments = HashMap.singleton "reason" - $ In.Argument reasonDescription reasonType + $ In.Argument reasonDescription (In.NamedScalarType Definition.string) $ Just "No longer supported" - reasonType = In.NamedScalarType Definition.string deprecatedDescription = Just "Marks an element of a GraphQL schema as no longer supported." deprecatedLocations = @@ -124,6 +124,16 @@ , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition , TypeSystemDirectiveLocation DirectiveLocation.EnumValue ] + specifiedByDirective = + Directive specifiedByDescription specifiedByArguments False specifiedByLocations + urlDescription = Just + "The URL that specifies the behavior of this scalar." + specifiedByArguments = HashMap.singleton "url" + $ In.Argument urlDescription (In.NonNullScalarType Definition.string) Nothing + specifiedByDescription = Just + "Exposes a URL that specifies the behavior of this scalar." + specifiedByLocations = + [TypeSystemDirectiveLocation DirectiveLocation.Scalar] -- | Traverses the schema and finds all referenced types. collectReferencedTypes :: forall m 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 @@ -200,7 +200,7 @@ directives context rule schemaLocation directives' Full.TypeDefinition typeDefinition' -> typeDefinition context rule typeDefinition' - Full.DirectiveDefinition _ _ arguments' _ -> + Full.DirectiveDefinition _ _ arguments' _ _ -> argumentsDefinition context rule arguments' typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition @@ -210,7 +210,7 @@ Full.ObjectTypeDefinition _ _ _ directives' fields -> directives context rule objectLocation directives' >< foldMap (fieldDefinition context rule) fields - Full.InterfaceTypeDefinition _ _ directives' fields + Full.InterfaceTypeDefinition _ _ _ directives' fields -> directives context rule interfaceLocation directives' >< foldMap (fieldDefinition context rule) fields Full.UnionTypeDefinition _ _ directives' _ -> @@ -283,7 +283,7 @@ schema' = Validation.schema context queryRoot = Just $ Out.NamedObjectType $ Schema.query schema' types' = Schema.types schema' - + typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut (Schema.ObjectType objectType) = Just $ Out.NamedObjectType objectType @@ -403,7 +403,7 @@ -> Seq (Validation.RuleT m) arguments rule argumentTypes = foldMap forEach . Seq.fromList where - forEach argument'@(Full.Argument argumentName _ _) = + forEach argument'@(Full.Argument argumentName _ _) = let argumentType = HashMap.lookup argumentName argumentTypes in argument rule argumentType argument' @@ -482,4 +482,4 @@ $ Validation.schema context in arguments rule argumentTypes arguments' where - directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes + directiveArguments (Schema.Directive _ argumentTypes _ _) = argumentTypes 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 @@ -50,14 +50,15 @@ 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, fold, foldl', toList) +import Data.Foldable (Foldable(..), find) 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.List (sortBy) import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty import Data.Ord (comparing) import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq @@ -136,25 +137,28 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty - case HashSet.size groupedFieldSet of - 1 -> lift mempty - _ - | Just name <- name' -> pure $ Error - { message = concat - [ "Subscription \"" - , Text.unpack name - , "\" must select only one top level field." - ] - , locations = [location'] - } - | otherwise -> pure $ Error - { message = errorMessage - , locations = [location'] - } + case HashSet.toList groupedFieldSet of + [rootName] + | Text.isPrefixOf "__" rootName -> makeError location' name' + "exactly one top level field, which must not be an introspection field." + | otherwise -> lift mempty + [] -> makeError location' name' "exactly one top level field." + _ -> makeError location' name' "only one top level field." _ -> lift mempty where - errorMessage = - "Anonymous Subscription must select only one top level field." + makeError location' (Just operationName) errorLine = pure $ Error + { message = concat + [ "Subscription \"" + , Text.unpack operationName + , "\" must select " + , errorLine + ] + , locations = [location'] + } + makeError location' Nothing errorLine = pure $ Error + { message = "Anonymous Subscription must select " <> errorLine + , locations = [location'] + } collectFields = foldM forEach HashSet.empty forEach accumulator = \case Full.FieldSelection fieldSelection -> forField accumulator fieldSelection @@ -253,14 +257,16 @@ -> Full.Location -> String -> RuleT m -findDuplicates filterByName thisLocation errorMessage = do - ast' <- asks ast - let locations' = foldr filterByName [] ast' - if length locations' > 1 && head locations' == thisLocation - then pure $ error' locations' - else lift mempty +findDuplicates filterByName thisLocation errorMessage = + asks ast >>= go . foldr filterByName [] where - error' locations' = Error + go locations' = + case locations' of + headLocation : otherLocations -- length locations' > 1 + | not $ null otherLocations + , headLocation == thisLocation -> pure $ makeError locations' + _ -> lift mempty + makeError locations' = Error { message = errorMessage , locations = locations' } @@ -530,16 +536,20 @@ -- used, the expected metadata or behavior becomes ambiguous, therefore only one -- of each directive is allowed per location. uniqueDirectiveNamesRule :: forall m. Rule m -uniqueDirectiveNamesRule = DirectivesRule - $ const $ lift . filterDuplicates extract "directive" - where - extract (Full.Directive directiveName _ location') = - (directiveName, location') - -groupSorted :: forall a. (a -> Text) -> [a] -> [[a]] -groupSorted getName = groupBy equalByName . sortOn getName +uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do + definitions' <- asks $ Schema.directives . schema + let filterNonRepeatable = flip HashSet.member nonRepeatableSet + . getField @"name" + nonRepeatableSet = + HashMap.foldlWithKey foldNonRepeatable HashSet.empty definitions' + lift $ filterDuplicates extract "directive" + $ filter filterNonRepeatable directives' where - equalByName lhs rhs = getName lhs == getName rhs + foldNonRepeatable hashSet directiveName' (Schema.Directive _ _ False _) = + HashSet.insert directiveName' hashSet + foldNonRepeatable hashSet _ _ = hashSet + extract (Full.Directive directiveName' _ location') = + (directiveName', location') filterDuplicates :: forall a . (a -> (Text, Full.Location)) @@ -549,12 +559,12 @@ filterDuplicates extract nodeType = Seq.fromList . fmap makeError . filter ((> 1) . length) - . groupSorted getName + . NonEmpty.groupAllWith getName where getName = fst . extract makeError directives' = Error - { message = makeMessage $ head directives' - , locations = snd . extract <$> directives' + { message = makeMessage $ NonEmpty.head directives' + , locations = snd . extract <$> toList directives' } makeMessage directive = concat [ "There can be only one " @@ -833,7 +843,7 @@ . Schema.directives . schema Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments case available of - Just (Schema.Directive _ _ definitions) + Just (Schema.Directive _ definitions _ _) | not $ HashMap.member argumentName definitions -> pure $ makeError argumentName directiveName location' _ -> lift mempty @@ -849,23 +859,23 @@ , "\"." ] --- | GraphQL servers define what directives they support. For each usage of a --- directive, the directive must be available on that server. +-- | GraphQL services define what directives they support. For each usage of a +-- directive, the directive must be available on that service. knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do definitions' <- asks $ Schema.directives . schema - let directiveSet = HashSet.fromList $ fmap directiveName directives' - let definitionSet = HashSet.fromList $ HashMap.keys definitions' - let difference = HashSet.difference directiveSet definitionSet - let undefined' = filter (definitionFilter difference) directives' + let directiveSet = HashSet.fromList $ fmap (getField @"name") directives' + definitionSet = HashSet.fromList $ HashMap.keys definitions' + difference = HashSet.difference directiveSet definitionSet + undefined' = filter (definitionFilter difference) directives' lift $ Seq.fromList $ makeError <$> undefined' where + definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool definitionFilter difference = flip HashSet.member difference - . directiveName - directiveName (Full.Directive directiveName' _ _) = directiveName' - makeError (Full.Directive directiveName' _ location') = Error - { message = errorMessage directiveName' - , locations = [location'] + . getField @"name" + makeError Full.Directive{..} = Error + { message = errorMessage name + , locations = [location] } errorMessage directiveName' = concat [ "Unknown directive \"@" @@ -902,9 +912,9 @@ , "\"." ] --- | GraphQL servers define what directives they support and where they support +-- | GraphQL services define what directives they support and where they support -- them. For each usage of a directive, the directive must be used in a location --- that the server has declared support for. +-- that the service has declared support for. directivesInValidLocationsRule :: Rule m directivesInValidLocationsRule = DirectivesRule directivesRule where @@ -913,7 +923,7 @@ maybeDefinition <- asks $ HashMap.lookup directiveName . Schema.directives . schema case maybeDefinition of - Just (Schema.Directive _ allowedLocations _) + Just (Schema.Directive _ _ _ allowedLocations) | directiveLocation `notElem` allowedLocations -> pure $ Error { message = errorMessage directiveName directiveLocation , locations = [location] @@ -943,7 +953,7 @@ available <- asks $ HashMap.lookup directiveName . Schema.directives . schema case available of - Just (Schema.Directive _ _ definitions) -> + Just (Schema.Directive _ definitions _ _) -> let forEach = go (directiveMessage directiveName) arguments location' in lift $ HashMap.foldrWithKey forEach Seq.empty definitions _ -> lift mempty @@ -1057,18 +1067,12 @@ 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{}) @@ -1095,10 +1099,6 @@ 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 @@ -1411,7 +1411,7 @@ let Full.Directive directiveName arguments _ = directive directiveDefinitions <- lift $ asks $ Schema.directives . schema case HashMap.lookup directiveName directiveDefinitions of - Just (Schema.Directive _ _ directiveArguments) -> + Just (Schema.Directive _ directiveArguments _ _) -> mapArguments variables directiveArguments arguments Nothing -> pure mempty mapArguments variables argumentTypes = fmap fold diff --git a/tests/Language/GraphQL/AST/Arbitrary.hs b/tests/Language/GraphQL/AST/Arbitrary.hs --- a/tests/Language/GraphQL/AST/Arbitrary.hs +++ b/tests/Language/GraphQL/AST/Arbitrary.hs @@ -1,15 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.GraphQL.AST.Arbitrary where +module Language.GraphQL.AST.Arbitrary + ( AnyArgument(..) + , AnyLocation(..) + , AnyName(..) + , AnyNode(..) + , AnyObjectField(..) + , AnyValue(..) + , printArgument + ) where import qualified Language.GraphQL.AST.Document as Doc import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..)) import Test.QuickCheck.Gen (Gen (..)) -import Data.Text (Text, pack) +import Data.Text (Text) +import qualified Data.Text as Text import Data.Functor ((<&>)) -newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show) +newtype AnyPrintableChar = AnyPrintableChar + { getAnyPrintableChar :: Char + } deriving (Eq, Show) alpha :: String alpha = ['a'..'z'] <> ['A'..'Z'] @@ -20,30 +31,42 @@ instance Arbitrary AnyPrintableChar where arbitrary = AnyPrintableChar <$> elements chars where - chars = alpha <> num <> ['_'] + chars = alpha <> num <> ['_'] -newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show) +newtype AnyPrintableText = AnyPrintableText + { getAnyPrintableText :: Text + } deriving (Eq, Show) instance Arbitrary AnyPrintableText where arbitrary = do nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar)) - pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr) + pure $ AnyPrintableText + $ Text.pack + $ map getAnyPrintableChar nonEmptyStr -- https://spec.graphql.org/June2018/#Name -newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show) +newtype AnyName = AnyName + { getAnyName :: Text + } deriving (Eq, Show) instance Arbitrary AnyName where arbitrary = do firstChar <- elements $ alpha <> ['_'] rest <- (arbitrary :: Gen [AnyPrintableChar]) - pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest) + pure $ AnyName + $ Text.pack + $ firstChar : map getAnyPrintableChar rest -newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show) +newtype AnyLocation = AnyLocation + { getAnyLocation :: Doc.Location + } deriving (Eq, Show) instance Arbitrary AnyLocation where arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary) -newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show) +newtype AnyNode a = AnyNode + { getAnyNode :: Doc.Node a + } deriving (Eq, Show) instance Arbitrary a => Arbitrary (AnyNode a) where arbitrary = do @@ -51,7 +74,9 @@ node' <- flip Doc.Node location' <$> arbitrary pure $ AnyNode node' -newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show) +newtype AnyObjectField a = AnyObjectField + { getAnyObjectField :: Doc.ObjectField a + } deriving (Eq, Show) instance Arbitrary a => Arbitrary (AnyObjectField a) where arbitrary = do @@ -60,8 +85,9 @@ location' <- getAnyLocation <$> arbitrary pure $ AnyObjectField $ Doc.ObjectField name' value' location' -newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } - deriving (Eq, Show) +newtype AnyValue = AnyValue + { getAnyValue :: Doc.Value + } deriving (Eq, Show) instance Arbitrary AnyValue where @@ -88,8 +114,9 @@ , Doc.Object <$> objectGen ] -newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } - deriving (Eq, Show) +newtype AnyArgument a = AnyArgument + { getAnyArgument :: Doc.Argument + } deriving (Eq, Show) instance Arbitrary a => Arbitrary (AnyArgument a) where arbitrary = do @@ -99,4 +126,5 @@ pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location' printArgument :: AnyArgument AnyValue -> Text -printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value' +printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = + name' <> ": " <> (Text.pack . show) value' diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.EncoderSpec ( spec ) where @@ -7,20 +6,17 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Encoder -import Language.GraphQL.TH import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) import Test.QuickCheck (choose, oneof, forAll) import qualified Data.Text.Lazy as Text.Lazy +import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation spec :: Spec spec = do describe "value" $ do - context "null value" $ do - let testNull formatter = value formatter Full.Null `shouldBe` "null" - it "minified" $ testNull minified - it "pretty" $ testNull pretty - context "minified" $ do + it "encodes null" $ + value minified Full.Null `shouldBe` "null" it "escapes \\" $ value minified (Full.String "\\") `shouldBe` "\"\\\\\"" it "escapes double quotes" $ @@ -46,113 +42,95 @@ it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\"" context "pretty" $ do + it "encodes null" $ + value pretty Full.Null `shouldBe` "null" + it "uses strings for short string values" $ value pretty (Full.String "Short text") `shouldBe` "\"Short text\"" it "uses block strings for text with new lines, with newline symbol" $ - let expected = [gql| - """ - Line 1 - Line 2 - """ - |] + let expected = "\"\"\"\n\ + \ Line 1\n\ + \ Line 2\n\ + \\"\"\"" actual = value pretty $ Full.String "Line 1\nLine 2" in actual `shouldBe` expected it "uses block strings for text with new lines, with CR symbol" $ - let expected = [gql| - """ - Line 1 - Line 2 - """ - |] + let expected = "\"\"\"\n\ + \ Line 1\n\ + \ Line 2\n\ + \\"\"\"" actual = value pretty $ Full.String "Line 1\rLine 2" in actual `shouldBe` expected it "uses block strings for text with new lines, with CR symbol followed by newline" $ - let expected = [gql| - """ - Line 1 - Line 2 - """ - |] + let expected = "\"\"\"\n\ + \ Line 1\n\ + \ Line 2\n\ + \\"\"\"" actual = value pretty $ Full.String "Line 1\r\nLine 2" in actual `shouldBe` expected it "encodes as one line string if has escaped symbols" $ do - let - genNotAllowedSymbol = oneof - [ choose ('\x0000', '\x0008') - , choose ('\x000B', '\x000C') - , choose ('\x000E', '\x001F') - , pure '\x007F' - ] - + let genNotAllowedSymbol = oneof + [ choose ('\x0000', '\x0008') + , choose ('\x000B', '\x000C') + , choose ('\x000E', '\x001F') + , pure '\x007F' + ] forAll genNotAllowedSymbol $ \x -> do - let - rawValue = "Short \n" <> Text.Lazy.cons x "text" - encoded = value pretty - $ Full.String $ Text.Lazy.toStrict rawValue - shouldStartWith (Text.Lazy.unpack encoded) "\"" - shouldEndWith (Text.Lazy.unpack encoded) "\"" - shouldNotContain (Text.Lazy.unpack encoded) "\"\"\"" + let rawValue = "Short \n" <> Text.Lazy.cons x "text" + encoded = Text.Lazy.unpack + $ value pretty + $ Full.String + $ Text.Lazy.toStrict rawValue + shouldStartWith encoded "\"" + shouldEndWith encoded "\"" + shouldNotContain encoded "\"\"\"" it "Hello world" $ let actual = value pretty $ Full.String "Hello,\n World!\n\nYours,\n GraphQL." - expected = [gql| - """ - Hello, - World! - - Yours, - GraphQL. - """ - |] + expected = "\"\"\"\n\ + \ Hello,\n\ + \ World!\n\ + \\n\ + \ Yours,\n\ + \ GraphQL.\n\ + \\"\"\"" in actual `shouldBe` expected it "has only newlines" $ let actual = value pretty $ Full.String "\n" - expected = [gql| - """ - - - """ - |] + expected = "\"\"\"\n\n\n\"\"\"" in actual `shouldBe` expected it "has newlines and one symbol at the begining" $ let actual = value pretty $ Full.String "a\n\n" - expected = [gql| - """ - a - - - """|] + expected = "\"\"\"\n\ + \ a\n\ + \\n\ + \\n\ + \\"\"\"" in actual `shouldBe` expected it "has newlines and one symbol at the end" $ let actual = value pretty $ Full.String "\n\na" - expected = [gql| - """ - - - a - """ - |] + expected = "\"\"\"\n\ + \\n\ + \\n\ + \ a\n\ + \\"\"\"" in actual `shouldBe` expected it "has newlines and one symbol in the middle" $ let actual = value pretty $ Full.String "\na\n" - expected = [gql| - """ - - a - - """ - |] + expected = "\"\"\"\n\ + \\n\ + \ a\n\ + \\n\ + \\"\"\"" in actual `shouldBe` expected it "skip trailing whitespaces" $ let actual = value pretty $ Full.String " Short\ntext " - expected = [gql| - """ - Short - text - """ - |] + expected = "\"\"\"\n\ + \ Short\n\ + \ text\n\ + \\"\"\"" in actual `shouldBe` expected describe "definition" $ @@ -164,14 +142,12 @@ fieldSelection = pure $ Full.FieldSelection field operation = Full.DefinitionOperation $ Full.SelectionSet fieldSelection location - expected = Text.Lazy.snoc [gql| - { - field(message: """ - line1 - line2 - """) - } - |] '\n' + expected = "{\n\ + \ field(message: \"\"\"\n\ + \ line1\n\ + \ line2\n\ + \ \"\"\")\n\ + \}\n" actual = definition pretty operation in actual `shouldBe` expected @@ -186,12 +162,10 @@ mutationType = Full.OperationTypeDefinition Full.Mutation "MutationType" operations = queryType :| pure mutationType definition' = Full.SchemaDefinition [] operations - expected = Text.Lazy.snoc [gql| - schema { - query: QueryRootType - mutation: MutationType - } - |] '\n' + expected = "schema {\n\ + \ query: QueryRootType\n\ + \ mutation: MutationType\n\ + \}\n" actual = typeSystemDefinition pretty definition' in actual `shouldBe` expected @@ -207,14 +181,12 @@ argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty arguments = Full.ArgumentsDefinition [argument] definition' = Full.TypeDefinition - $ Full.InterfaceTypeDefinition mempty "UUID" mempty + $ Full.InterfaceTypeDefinition mempty "UUID" (Full.ImplementsInterfaces []) mempty $ pure $ Full.FieldDefinition mempty "value" arguments someType mempty - expected = [gql| - interface UUID { - value(arg: String): String - } - |] + expected = "interface UUID {\n\ + \ value(arg: String): String\n\ + \}" actual = typeSystemDefinition pretty definition' in actual `shouldBe` expected @@ -222,11 +194,9 @@ let definition' = Full.TypeDefinition $ Full.UnionTypeDefinition mempty "SearchResult" mempty $ Full.UnionMemberTypes ["Photo", "Person"] - expected = [gql| - union SearchResult = - | Photo - | Person - |] + expected = "union SearchResult =\n\ + \ | Photo\n\ + \ | Person" actual = typeSystemDefinition pretty definition' in actual `shouldBe` expected @@ -239,14 +209,12 @@ ] definition' = Full.TypeDefinition $ Full.EnumTypeDefinition mempty "Direction" mempty values - expected = [gql| - enum Direction { - NORTH - EAST - SOUTH - WEST - } - |] + expected = "enum Direction {\n\ + \ NORTH\n\ + \ EAST\n\ + \ SOUTH\n\ + \ WEST\n\ + \}" actual = typeSystemDefinition pretty definition' in actual `shouldBe` expected @@ -259,11 +227,28 @@ ] definition' = Full.TypeDefinition $ Full.InputObjectTypeDefinition mempty "ExampleInputObject" mempty fields - expected = [gql| - input ExampleInputObject { - a: String - b: Int! - } - |] + expected = "input ExampleInputObject {\n\ + \ a: String\n\ + \ b: Int!\n\ + \}" actual = typeSystemDefinition pretty definition' in actual `shouldBe` expected + + context "directive definition" $ do + it "encodes a directive definition" $ do + let definition' = Full.DirectiveDefinition mempty "example" mempty False + $ pure + $ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field + expected = "@example() on\n\ + \ | FIELD" + actual = typeSystemDefinition pretty definition' + in actual `shouldBe` expected + + it "encodes a repeatable directive definition" $ do + let definition' = Full.DirectiveDefinition mempty "example" mempty True + $ pure + $ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field + expected = "@example() repeatable on\n\ + \ | FIELD" + actual = typeSystemDefinition pretty definition' + in actual `shouldBe` expected diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.LexerSpec ( spec ) where @@ -7,7 +6,6 @@ import Data.Text (Text) import Data.Void (Void) import Language.GraphQL.AST.Lexer -import Language.GraphQL.TH import Test.Hspec (Spec, context, describe, it) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (ParseErrorBundle, parse) @@ -19,38 +17,39 @@ parse unicodeBOM "" `shouldSucceedOn` "\xfeff" it "lexes strings" $ do - parse string "" [gql|"simple"|] `shouldParse` "simple" - parse string "" [gql|" white space "|] `shouldParse` " white space " - parse string "" [gql|"quote \""|] `shouldParse` [gql|quote "|] - parse string "" [gql|"escaped \n"|] `shouldParse` "escaped \n" - parse string "" [gql|"slashes \\ \/"|] `shouldParse` [gql|slashes \ /|] - parse string "" [gql|"unicode \u1234\u5678\u90AB\uCDEF"|] + parse string "" "\"simple\"" `shouldParse` "simple" + parse string "" "\" white space \"" `shouldParse` " white space " + parse string "" "\"quote \\\"\"" `shouldParse` "quote \"" + parse string "" "\"escaped \\n\"" `shouldParse` "escaped \n" + parse string "" "\"slashes \\\\ \\/\"" `shouldParse` "slashes \\ /" + parse string "" "\"unicode \\u1234\\u5678\\u90AB\\uCDEF\"" `shouldParse` "unicode ሴ噸邫췯" it "lexes block string" $ do - parse blockString "" [gql|"""simple"""|] `shouldParse` "simple" - parse blockString "" [gql|""" white space """|] + parse blockString "" "\"\"\"simple\"\"\"" `shouldParse` "simple" + parse blockString "" "\"\"\" white space \"\"\"" `shouldParse` " white space " - parse blockString "" [gql|"""contains " quote"""|] - `shouldParse` [gql|contains " quote|] - parse blockString "" [gql|"""contains \""" triplequote"""|] - `shouldParse` [gql|contains """ triplequote|] + parse blockString "" "\"\"\"contains \" quote\"\"\"" + `shouldParse` "contains \" quote" + parse blockString "" "\"\"\"contains \\\"\"\" triplequote\"\"\"" + `shouldParse` "contains \"\"\" triplequote" parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline" parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\"" `shouldParse` "multi\nline\nnormalized" parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\"" `shouldParse` "multi\nline\nnormalized" - parse blockString "" [gql|"""unescaped \n\r\b\t\f\u1234"""|] - `shouldParse` [gql|unescaped \n\r\b\t\f\u1234|] - parse blockString "" [gql|"""slashes \\ \/"""|] - `shouldParse` [gql|slashes \\ \/|] - parse blockString "" [gql|""" - - spans - multiple - lines - - """|] `shouldParse` "spans\n multiple\n lines" + parse blockString "" "\"\"\"unescaped \\n\\r\\b\\t\\f\\u1234\"\"\"" + `shouldParse` "unescaped \\n\\r\\b\\t\\f\\u1234" + parse blockString "" "\"\"\"slashes \\\\ \\/\"\"\"" + `shouldParse` "slashes \\\\ \\/" + parse blockString "" "\"\"\"\n\ + \\n\ + \ spans\n\ + \ multiple\n\ + \ lines\n\ + \\n\ + \\"\"\"" + `shouldParse` "spans\n multiple\n lines" it "lexes numbers" $ do parse integer "" "4" `shouldParse` (4 :: Int) @@ -84,7 +83,7 @@ context "Implementation tests" $ do it "lexes empty block strings" $ - parse blockString "" [gql|""""""|] `shouldParse` "" + parse blockString "" "\"\"\"\"\"\"" `shouldParse` "" it "lexes ampersand" $ parse amp "" "&" `shouldParse` "&" it "lexes schema extensions" $ diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -1,18 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.ParserSpec ( spec ) where import Data.List.NonEmpty (NonEmpty(..)) -import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc import Language.GraphQL.AST.Parser -import Language.GraphQL.TH import Test.Hspec (Spec, describe, it, context) -import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) +import Test.Hspec.Megaparsec + ( shouldParse + , shouldFailOn + , parseSatisfies + , shouldSucceedOn + ) import Text.Megaparsec (parse) import Test.QuickCheck (property, NonEmptyList (..), mapSize) import Language.GraphQL.AST.Arbitrary @@ -23,182 +25,160 @@ parse document "" `shouldSucceedOn` "\xfeff{foo}" context "Arguments" $ do - it "accepts block strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: """Argument""") - }|] + it "accepts block strings as argument" $ + parse document "" `shouldSucceedOn` + "{ hello(text: \"\"\"Argument\"\"\") }" - it "accepts strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: "Argument") - }|] + it "accepts strings as argument" $ + parse document "" `shouldSucceedOn` "{ hello(text: \"Argument\") }" - it "accepts int as argument1" $ - parse document "" `shouldSucceedOn` [gql|{ - user(id: 4) - }|] + it "accepts int as argument" $ + parse document "" `shouldSucceedOn` "{ user(id: 4) }" - it "accepts boolean as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(flag: true) { field1 } - }|] + it "accepts boolean as argument" $ + parse document "" `shouldSucceedOn` + "{ hello(flag: true) { field1 } }" - it "accepts float as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - body(height: 172.5) { height } - }|] + it "accepts float as argument" $ + parse document "" `shouldSucceedOn` + "{ body(height: 172.5) { height } }" - it "accepts empty list as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - query(list: []) { field1 } - }|] + it "accepts empty list as argument" $ + parse document "" `shouldSucceedOn` "{ query(list: []) { field1 } }" - it "accepts two required arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth($username: String!, $password: String!){ - test - }|] + it "accepts two required arguments" $ + parse document "" `shouldSucceedOn` + "mutation auth($username: String!, $password: String!) { test }" - it "accepts two string arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth{ - test(username: "username", password: "password") - }|] + it "accepts two string arguments" $ + parse document "" `shouldSucceedOn` + "mutation auth { test(username: \"username\", password: \"password\") }" - it "accepts two block string arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth{ - test(username: """username""", password: """password""") - }|] - - it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> - let - query' :: Text - arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) - query' = "query(" <> Text.intercalate ", " arguments <> ")" in - parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") + it "accepts two block string arguments" $ + let given = "mutation auth {\n\ + \ test(username: \"\"\"username\"\"\", password: \"\"\"password\"\"\")\n\ + \}" + in parse document "" `shouldSucceedOn` given + it "fails to parse an empty argument list in parens" $ + parse document "" `shouldFailOn` "{ test() }" + + it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> + let arguments' = map printArgument + $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) + query' = "query(" <> Text.intercalate ", " arguments' <> ")" + in parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") + it "parses minimal schema definition" $ - parse document "" `shouldSucceedOn` [gql|schema { query: Query }|] + parse document "" `shouldSucceedOn` "schema { query: Query }" it "parses minimal scalar definition" $ - parse document "" `shouldSucceedOn` [gql|scalar Time|] + parse document "" `shouldSucceedOn` "scalar Time" it "parses ImplementsInterfaces" $ - parse document "" `shouldSucceedOn` [gql| - type Person implements NamedEntity & ValuedEntity { - name: String - } - |] + parse document "" `shouldSucceedOn` + "type Person implements NamedEntity & ValuedEntity {\n\ + \ name: String\n\ + \}" it "parses a type without ImplementsInterfaces" $ - parse document "" `shouldSucceedOn` [gql| - type Person { - name: String - } - |] + parse document "" `shouldSucceedOn` + "type Person {\n\ + \ name: String\n\ + \}" it "parses ArgumentsDefinition in an ObjectDefinition" $ - parse document "" `shouldSucceedOn` [gql| - type Person { - name(first: String, last: String): String - } - |] + parse document "" `shouldSucceedOn` + "type Person {\n\ + \ name(first: String, last: String): String\n\ + \}" it "parses minimal union type definition" $ - parse document "" `shouldSucceedOn` [gql| - union SearchResult = Photo | Person - |] + parse document "" `shouldSucceedOn` + "union SearchResult = Photo | Person" it "parses minimal interface type definition" $ - parse document "" `shouldSucceedOn` [gql| - interface NamedEntity { - name: String - } - |] + parse document "" `shouldSucceedOn` + "interface NamedEntity {\n\ + \ name: String\n\ + \}" + it "parses ImplementsInterfaces on interfaces" $ + parse document "" `shouldSucceedOn` + "interface Person implements NamedEntity & ValuedEntity {\n\ + \ name: String\n\ + \}" + it "parses minimal enum type definition" $ - parse document "" `shouldSucceedOn` [gql| - enum Direction { - NORTH - EAST - SOUTH - WEST - } - |] + parse document "" `shouldSucceedOn` + "enum Direction {\n\ + \ NORTH\n\ + \ EAST\n\ + \ SOUTH\n\ + \ WEST\n\ + \}" it "parses minimal input object type definition" $ - parse document "" `shouldSucceedOn` [gql| - input Point2D { - x: Float - y: Float - } - |] + parse document "" `shouldSucceedOn` + "input Point2D {\n\ + \ x: Float\n\ + \ y: Float\n\ + \}" it "parses minimal input enum definition with an optional pipe" $ - parse document "" `shouldSucceedOn` [gql| - directive @example on - | FIELD - | FRAGMENT_SPREAD - |] + parse document "" `shouldSucceedOn` + "directive @example on\n\ + \ | FIELD\n\ + \ | FRAGMENT_SPREAD" it "parses two minimal directive definitions" $ - let directive nm loc = - TypeSystemDefinition - (DirectiveDefinition - (Description Nothing) - nm - (ArgumentsDefinition []) - (loc :| [])) - example1 = - directive "example1" - (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) - (Location {line = 1, column = 1}) - example2 = - directive "example2" - (DirLoc.ExecutableDirectiveLocation DirLoc.Field) - (Location {line = 2, column = 1}) - testSchemaExtension = example1 :| [ example2 ] - query = [gql| - directive @example1 on FIELD_DEFINITION - directive @example2 on FIELD - |] + let directive name' loc = TypeSystemDefinition + $ DirectiveDefinition + (Description Nothing) + name' + (ArgumentsDefinition []) + False + (loc :| []) + example1 = directive "example1" + (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) + (Location {line = 1, column = 1}) + example2 = directive "example2" + (DirLoc.ExecutableDirectiveLocation DirLoc.Field) + (Location {line = 2, column = 1}) + testSchemaExtension = example1 :| [example2] + query = Text.unlines + [ "directive @example1 on FIELD_DEFINITION" + , "directive @example2 on FIELD" + ] in parse document "" query `shouldParse` testSchemaExtension it "parses a directive definition with a default empty list argument" $ - let directive nm loc args = - TypeSystemDefinition - (DirectiveDefinition - (Description Nothing) - nm - (ArgumentsDefinition - [ InputValueDefinition - (Description Nothing) - argName - argType - argValue - [] - | (argName, argType, argValue) <- args]) - (loc :| [])) - defn = - directive "test" - (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) - [("foo", - TypeList (TypeNamed "String"), - Just - $ Node (ConstList []) - $ Location {line = 1, column = 33})] - (Location {line = 1, column = 1}) - query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|] - in parse document "" query `shouldParse` (defn :| [ ]) + let argumentValue = Just + $ Node (ConstList []) + $ Location{ line = 1, column = 33 } + loc = DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition + argumentValueDefinition = InputValueDefinition + (Description Nothing) + "foo" + (TypeList (TypeNamed "String")) + argumentValue + [] + definition = DirectiveDefinition + (Description Nothing) + "test" + (ArgumentsDefinition [argumentValueDefinition]) + False + (loc :| []) + directive = TypeSystemDefinition definition + $ Location{ line = 1, column = 1 } + query = "directive @test(foo: [String] = []) on FIELD_DEFINITION" + in parse document "" query `shouldParse` (directive :| []) it "parses schema extension with a new directive" $ - parse document "" `shouldSucceedOn`[gql| - extend schema @newDirective - |] + parse document "" `shouldSucceedOn` "extend schema @newDirective" it "parses schema extension with an operation type definition" $ - parse document "" `shouldSucceedOn` [gql|extend schema { query: Query }|] + parse document "" `shouldSucceedOn` "extend schema { query: Query }" it "parses schema extension with an operation type and directive" $ let newDirective = Directive "newDirective" [] $ Location 1 15 @@ -207,45 +187,42 @@ $ OperationTypeDefinition Query "Query" :| [] testSchemaExtension = TypeSystemExtension schemaExtension $ Location 1 1 - query = [gql|extend schema @newDirective { query: Query }|] + query = "extend schema @newDirective { query: Query }" in parse document "" query `shouldParse` (testSchemaExtension :| []) + it "parses a repeatable directive definition" $ + let given = "directive @test repeatable on FIELD_DEFINITION" + isRepeatable (TypeSystemDefinition definition' _ :| []) + | DirectiveDefinition _ _ _ repeatable _ <- definition' = repeatable + isRepeatable _ = False + in parse document "" given `parseSatisfies` isRepeatable + it "parses an object extension" $ - parse document "" `shouldSucceedOn` [gql| - extend type Story { - isHiddenLocally: Boolean - } - |] + parse document "" `shouldSucceedOn` + "extend type Story { isHiddenLocally: Boolean }" it "rejects variables in DefaultValue" $ - parse document "" `shouldFailOn` [gql| - query ($book: String = "Zarathustra", $author: String = $book) { - title - } - |] + parse document "" `shouldFailOn` + "query ($book: String = \"Zarathustra\", $author: String = $book) {\n\ + \ title\n\ + \}" it "rejects empty selection set" $ - parse document "" `shouldFailOn` [gql| - query { - innerField {} - } - |] + parse document "" `shouldFailOn` "query { innerField {} }" it "parses documents beginning with a comment" $ - parse document "" `shouldSucceedOn` [gql| - """ - Query - """ - type Query { - queryField: String - } - |] + parse document "" `shouldSucceedOn` + "\"\"\"\n\ + \Query\n\ + \\"\"\"\n\ + \type Query {\n\ + \ queryField: String\n\ + \}" it "parses subscriptions" $ - parse document "" `shouldSucceedOn` [gql| - subscription NewMessages { - newMessage(roomId: 123) { - sender - } - } - |] + parse document "" `shouldSucceedOn` + "subscription NewMessages {\n\ + \ newMessage(roomId: 123) {\n\ + \ sender\n\ + \ }\n\ + \}" diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -5,9 +5,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.ExecuteSpec ( spec @@ -23,7 +21,6 @@ import Language.GraphQL.AST.Parser (document) import Language.GraphQL.Error import Language.GraphQL.Execute (execute) -import Language.GraphQL.TH import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type as Type import Language.GraphQL.Type @@ -269,15 +266,15 @@ spec = describe "execute" $ do it "rejects recursive fragments" $ - let sourceQuery = [gql| - { - ...cyclicFragment - } - - fragment cyclicFragment on Query { - ...cyclicFragment - } - |] + let sourceQuery = "\ + \{\n\ + \ ...cyclicFragment\n\ + \}\n\ + \\n\ + \fragment cyclicFragment on Query {\n\ + \ ...cyclicFragment\n\ + \}\ + \" expected = Response (Object mempty) mempty in sourceQuery `shouldResolveTo` expected diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs --- a/tests/Language/GraphQL/Validate/RulesSpec.hs +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -3,7 +3,6 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.Validate.RulesSpec ( spec @@ -13,8 +12,9 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Language.GraphQL.AST as AST -import Language.GraphQL.TH import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Schema as Schema +import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Validate @@ -22,7 +22,9 @@ import Text.Megaparsec (parse, errorBundlePretty) petSchema :: Schema IO -petSchema = schema queryType Nothing (Just subscriptionType) mempty +petSchema = schema queryType Nothing (Just subscriptionType) + $ HashMap.singleton "repeat" + $ Schema.Directive Nothing mempty True [DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field] queryType :: ObjectType IO queryType = ObjectType "Query" Nothing [] $ HashMap.fromList @@ -92,7 +94,7 @@ , ("nickname", nicknameResolver) , ("barkVolume", barkVolumeResolver) , ("doesKnowCommand", doesKnowCommandResolver) - , ("isHousetrained", isHousetrainedResolver) + , ("isHouseTrained", isHouseTrainedResolver) , ("owner", ownerResolver) ] where @@ -103,10 +105,10 @@ $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing doesKnowCommandResolver = ValueResolver doesKnowCommandField $ pure $ Boolean True - isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean) + isHouseTrainedField = Field Nothing (Out.NonNullScalarType boolean) $ HashMap.singleton "atOtherHomes" $ In.Argument Nothing (In.NamedScalarType boolean) Nothing - isHousetrainedResolver = ValueResolver isHousetrainedField + isHouseTrainedResolver = ValueResolver isHouseTrainedField $ pure $ Boolean True ownerField = Field Nothing (Out.NamedObjectType humanType) mempty ownerResolver = ValueResolver ownerField $ pure Null @@ -169,18 +171,16 @@ describe "document" $ do context "executableDefinitionsRule" $ it "rejects type definitions" $ - let queryString = [gql| - query getDogName { - dog { - name - color - } - } - - extend type Dog { - color: String - } - |] + let queryString = "query getDogName {\n\ + \ dog {\n\ + \ name\n\ + \ color\n\ + \ }\n\ + \}\n\ + \\n\ + \extend type Dog {\n\ + \ color: String\n\ + \}" expected = Error { message = "Definition must be OperationDefinition or \ @@ -191,15 +191,13 @@ context "singleFieldSubscriptionsRule" $ do it "rejects multiple subscription root fields" $ - let queryString = [gql| - subscription sub { - newMessage { - body - sender - } - disallowedSecondRootField - } - |] + let queryString = "subscription sub {\n\ + \ newMessage {\n\ + \ body\n\ + \ sender\n\ + \ }\n\ + \ disallowedSecondRootField\n\ + \}" expected = Error { message = "Subscription \"sub\" must select only one top \ @@ -208,20 +206,30 @@ } in validate queryString `shouldContain` [expected] - it "rejects multiple subscription root fields coming from a fragment" $ - let queryString = [gql| - subscription sub { - ...multipleSubscriptions - } + it "rejects an introspection field as the subscription root" $ + let queryString = "subscription sub {\n\ + \ __typename\n\ + \}" + expected = Error + { message = + "Subscription \"sub\" must select exactly one top \ + \level field, which must not be an introspection field." + , locations = [AST.Location 1 1] + } + in validate queryString `shouldContain` [expected] - fragment multipleSubscriptions on Subscription { - newMessage { - body - sender - } - disallowedSecondRootField - } - |] + it "rejects multiple subscription root fields coming from a fragment" $ + let queryString = "subscription sub {\n\ + \ ...multipleSubscriptions\n\ + \}\n\ + \\n\ + \fragment multipleSubscriptions on Subscription {\n\ + \ newMessage {\n\ + \ body\n\ + \ sender\n\ + \ }\n\ + \ disallowedSecondRootField\n\ + \}" expected = Error { message = "Subscription \"sub\" must select only one top \ @@ -231,26 +239,24 @@ in validate queryString `shouldContain` [expected] it "finds corresponding subscription fragment" $ - let queryString = [gql| - subscription sub { - ...anotherSubscription - ...multipleSubscriptions - } - fragment multipleSubscriptions on Subscription { - newMessage { - body - } - disallowedSecondRootField { - sender - } - } - fragment anotherSubscription on Subscription { - newMessage { - body - sender - } - } - |] + let queryString = "subscription sub {\n\ + \ ...anotherSubscription\n\ + \ ...multipleSubscriptions\n\ + \}\n\ + \fragment multipleSubscriptions on Subscription {\n\ + \ newMessage {\n\ + \ body\n\ + \ }\n\ + \ disallowedSecondRootField {\n\ + \ sender\n\ + \ }\n\ + \}\n\ + \fragment anotherSubscription on Subscription {\n\ + \ newMessage {\n\ + \ body\n\ + \ sender\n\ + \ }\n\ + \}" expected = Error { message = "Subscription \"sub\" must select only one top \ @@ -261,21 +267,19 @@ context "loneAnonymousOperationRule" $ it "rejects multiple anonymous operations" $ - let queryString = [gql| - { - dog { - name - } - } - - query getName { - dog { - owner { - name - } - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ name\n\ + \ }\n\ + \}\n\ + \\n\ + \query getName {\n\ + \ dog {\n\ + \ owner {\n\ + \ name\n\ + \ }\n\ + \ }\n\ + \}" expected = Error { message = "This anonymous operation must be the only defined \ @@ -286,19 +290,17 @@ context "uniqueOperationNamesRule" $ it "rejects operations with the same name" $ - let queryString = [gql| - query dogOperation { - dog { - name - } - } - - mutation dogOperation { - mutateDog { - id - } - } - |] + let queryString = "query dogOperation {\n\ + \ dog {\n\ + \ name\n\ + \ }\n\ + \}\n\ + \\n\ + \mutation dogOperation {\n\ + \ mutateDog {\n\ + \ id\n\ + \ }\n\ + \}" expected = Error { message = "There can be only one operation named \ @@ -309,23 +311,21 @@ context "uniqueFragmentNamesRule" $ it "rejects fragments with the same name" $ - let queryString = [gql| - { - dog { - ...fragmentOne - } - } - - fragment fragmentOne on Dog { - name - } - - fragment fragmentOne on Dog { - owner { - name - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ...fragmentOne\n\ + \ }\n\ + \}\n\ + \\n\ + \fragment fragmentOne on Dog {\n\ + \ name\n\ + \}\n\ + \\n\ + \fragment fragmentOne on Dog {\n\ + \ owner {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "There can be only one fragment named \ @@ -336,13 +336,11 @@ context "fragmentSpreadTargetDefinedRule" $ it "rejects the fragment spread without a target" $ - let queryString = [gql| - { - dog { - ...undefinedFragment - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ...undefinedFragment\n\ + \ }\n\ + \}" expected = Error { message = "Fragment target \"undefinedFragment\" is \ @@ -353,16 +351,14 @@ context "fragmentSpreadTypeExistenceRule" $ do it "rejects fragment spreads without an unknown target type" $ - let queryString = [gql| - { - dog { - ...notOnExistingType - } - } - fragment notOnExistingType on NotInSchema { - name - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ...notOnExistingType\n\ + \ }\n\ + \}\n\ + \fragment notOnExistingType on NotInSchema {\n\ + \ name\n\ + \}" expected = Error { message = "Fragment \"notOnExistingType\" is specified on \ @@ -373,13 +369,11 @@ in validate queryString `shouldBe` [expected] it "rejects inline fragments without a target" $ - let queryString = [gql| - { - ... on NotInSchema { - name - } - } - |] + let queryString = "{\n\ + \ ... on NotInSchema {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Inline fragment is specified on type \ @@ -390,16 +384,14 @@ context "fragmentsOnCompositeTypesRule" $ do it "rejects fragments on scalar types" $ - let queryString = [gql| - { - dog { - ...fragOnScalar - } - } - fragment fragOnScalar on Int { - name - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ...fragOnScalar\n\ + \ }\n\ + \}\n\ + \fragment fragOnScalar on Int {\n\ + \ name\n\ + \}" expected = Error { message = "Fragment cannot condition on non composite type \ @@ -409,13 +401,11 @@ in validate queryString `shouldContain` [expected] it "rejects inline fragments on scalar types" $ - let queryString = [gql| - { - ... on Boolean { - name - } - } - |] + let queryString = "{\n\ + \ ... on Boolean {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Fragment cannot condition on non composite type \ @@ -426,17 +416,15 @@ context "noUnusedFragmentsRule" $ it "rejects unused fragments" $ - let queryString = [gql| - fragment nameFragment on Dog { # unused - name - } - - { - dog { - name - } - } - |] + let queryString = "fragment nameFragment on Dog { # unused\n\ + \ name\n\ + \}\n\ + \\n\ + \{\n\ + \ dog {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Fragment \"nameFragment\" is never used." @@ -446,21 +434,19 @@ context "noFragmentCyclesRule" $ it "rejects spreads that form cycles" $ - let queryString = [gql| - { - dog { - ...nameFragment - } - } - fragment nameFragment on Dog { - name - ...barkVolumeFragment - } - fragment barkVolumeFragment on Dog { - barkVolume - ...nameFragment - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ...nameFragment\n\ + \ }\n\ + \}\n\ + \fragment nameFragment on Dog {\n\ + \ name\n\ + \ ...barkVolumeFragment\n\ + \}\n\ + \fragment barkVolumeFragment on Dog {\n\ + \ barkVolume\n\ + \ ...nameFragment\n\ + \}" error1 = Error { message = "Cannot spread fragment \"barkVolumeFragment\" \ @@ -479,13 +465,11 @@ context "uniqueArgumentNamesRule" $ it "rejects duplicate field arguments" $ - let queryString = [gql| - { - dog { - isHousetrained(atOtherHomes: true, atOtherHomes: true) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: true, atOtherHomes: true)\n\ + \ }\n\ + \}" expected = Error { message = "There can be only one argument named \ @@ -494,15 +478,13 @@ } in validate queryString `shouldBe` [expected] - context "uniqueDirectiveNamesRule" $ + context "uniqueDirectiveNamesRule" $ do it "rejects more than one directive per location" $ - let queryString = [gql| - query ($foo: Boolean = true, $bar: Boolean = false) { - dog @skip(if: $foo) @skip(if: $bar) { - name - } - } - |] + let queryString = "query ($foo: Boolean = true, $bar: Boolean = false) {\n\ + \ dog @skip(if: $foo) @skip(if: $bar) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "There can be only one directive named \"skip\"." @@ -510,15 +492,21 @@ } in validate queryString `shouldBe` [expected] + it "allows repeating repeatable directives" $ + let queryString = "query {\n\ + \ dog @repeat @repeat {\n\ + \ name\n\ + \ }\n\ + \}" + in validate queryString `shouldBe` [] + context "uniqueVariableNamesRule" $ it "rejects duplicate variables" $ - let queryString = [gql| - query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) { - dog { - isHousetrained(atOtherHomes: $atOtherHomes) - } - } - |] + let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: $atOtherHomes)\n\ + \ }\n\ + \}" expected = Error { message = "There can be only one variable named \ @@ -529,13 +517,11 @@ context "variablesAreInputTypesRule" $ it "rejects non-input types as variables" $ - let queryString = [gql| - query takesDogBang($dog: Dog!) { - dog { - isHousetrained(atOtherHomes: $dog) - } - } - |] + let queryString = "query takesDogBang($dog: Dog!) {\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: $dog)\n\ + \ }\n\ + \}" expected = Error { message = "Variable \"$dog\" cannot be non-input type \ @@ -546,17 +532,15 @@ context "noUndefinedVariablesRule" $ do it "rejects undefined variables" $ - let queryString = [gql| - query variableIsNotDefinedUsedInSingleFragment { - dog { - ...isHousetrainedFragment - } - } - - fragment isHousetrainedFragment on Dog { - isHousetrained(atOtherHomes: $atOtherHomes) - } - |] + let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\ + \ dog {\n\ + \ ...isHouseTrainedFragment\n\ + \ }\n\ + \}\n\ + \\n\ + \fragment isHouseTrainedFragment on Dog {\n\ + \ isHouseTrained(atOtherHomes: $atOtherHomes)\n\ + \}" expected = Error { message = "Variable \"$atOtherHomes\" is not defined by \ @@ -567,13 +551,11 @@ in validate queryString `shouldBe` [expected] it "gets variable location inside an input object" $ - let queryString = [gql| - query { - findDog (complex: { name: $name }) { - name - } - } - |] + let queryString = "query {\n\ + \ findDog (complex: { name: $name }) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Variable \"$name\" is not defined." , locations = [AST.Location 2 29] @@ -581,13 +563,11 @@ in validate queryString `shouldBe` [expected] it "gets variable location inside an array" $ - let queryString = [gql| - query { - findCats (commands: [JUMP, $command]) { - name - } - } - |] + let queryString = "query {\n\ + \ findCats (commands: [JUMP, $command]) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Variable \"$command\" is not defined." , locations = [AST.Location 2 30] @@ -596,13 +576,11 @@ context "noUnusedVariablesRule" $ do it "rejects unused variables" $ - let queryString = [gql| - query variableUnused($atOtherHomes: Boolean) { - dog { - isHousetrained - } - } - |] + let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\ + \ dog {\n\ + \ isHouseTrained\n\ + \ }\n\ + \}" expected = Error { message = "Variable \"$atOtherHomes\" is never used in \ @@ -612,24 +590,20 @@ in validate queryString `shouldBe` [expected] it "detects variables in properties of input objects" $ - let queryString = [gql| - query withVar ($name: String!) { - findDog (complex: { name: $name }) { - name - } - } - |] + let queryString = "query withVar ($name: String!) {\n\ + \ findDog (complex: { name: $name }) {\n\ + \ name\n\ + \ }\n\ + \}" in validate queryString `shouldBe` [] context "uniqueInputFieldNamesRule" $ it "rejects duplicate fields in input objects" $ - let queryString = [gql| - { - findDog(complex: { name: "Fido", name: "Jack" }) { - name - } - } - |] + let queryString = "{\n\ + \ findDog(complex: { name: \"Fido\", name: \"Jack\" }) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "There can be only one input field named \"name\"." @@ -639,13 +613,11 @@ context "fieldsOnCorrectTypeRule" $ it "rejects undefined fields" $ - let queryString = [gql| - { - dog { - meowVolume - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ meowVolume\n\ + \ }\n\ + \}" expected = Error { message = "Cannot query field \"meowVolume\" on type \"Dog\"." @@ -655,15 +627,13 @@ context "scalarLeafsRule" $ it "rejects scalar fields with not empty selection set" $ - let queryString = [gql| - { - dog { - barkVolume { - sinceWhen - } - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ barkVolume {\n\ + \ sinceWhen\n\ + \ }\n\ + \ }\n\ + \}" expected = Error { message = "Field \"barkVolume\" must not have a selection \ @@ -674,13 +644,11 @@ context "knownArgumentNamesRule" $ do it "rejects field arguments missing in the type" $ - let queryString = [gql| - { - dog { - doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)\n\ + \ }\n\ + \}" expected = Error { message = "Unknown argument \"command\" on field \ @@ -690,13 +658,11 @@ in validate queryString `shouldBe` [expected] it "rejects directive arguments missing in the definition" $ - let queryString = [gql| - { - dog { - isHousetrained(atOtherHomes: true) @include(unless: false, if: true) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: true) @include(unless: false, if: true)\n\ + \ }\n\ + \}" expected = Error { message = "Unknown argument \"unless\" on directive \ @@ -707,13 +673,11 @@ context "knownDirectiveNamesRule" $ it "rejects undefined directives" $ - let queryString = [gql| - { - dog { - isHousetrained(atOtherHomes: true) @ignore(if: true) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: true) @ignore(if: true)\n\ + \ }\n\ + \}" expected = Error { message = "Unknown directive \"@ignore\"." , locations = [AST.Location 3 40] @@ -722,13 +686,11 @@ context "knownInputFieldNamesRule" $ it "rejects undefined input object fields" $ - let queryString = [gql| - { - findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) { - name - } - } - |] + let queryString = "{\n\ + \ findDog(complex: { favoriteCookieFlavor: \"Bacon\", name: \"Jack\" }) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Field \"favoriteCookieFlavor\" is not defined \ @@ -739,13 +701,11 @@ context "directivesInValidLocationsRule" $ it "rejects directives in invalid locations" $ - let queryString = [gql| - query @skip(if: $foo) { - dog { - name - } - } - |] + let queryString = "query @skip(if: $foo) {\n\ + \ dog {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Directive \"@skip\" may not be used on QUERY." @@ -755,14 +715,12 @@ context "overlappingFieldsCanBeMergedRule" $ do it "fails to merge fields of mismatching types" $ - let queryString = [gql| - { - dog { - name: nickname - name - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ name: nickname\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Fields \"name\" conflict because \"nickname\" and \ @@ -774,14 +732,12 @@ in validate queryString `shouldBe` [expected] it "fails if the arguments of the same field don't match" $ - let queryString = [gql| - { - dog { - doesKnowCommand(dogCommand: SIT) - doesKnowCommand(dogCommand: HEEL) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ doesKnowCommand(dogCommand: SIT)\n\ + \ doesKnowCommand(dogCommand: HEEL)\n\ + \ }\n\ + \}" expected = Error { message = "Fields \"doesKnowCommand\" conflict because they \ @@ -793,18 +749,16 @@ in validate queryString `shouldBe` [expected] it "fails to merge same-named field and alias" $ - let queryString = [gql| - { - dog { - doesKnowCommand(dogCommand: SIT) - doesKnowCommand: isHousetrained(atOtherHomes: true) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ doesKnowCommand(dogCommand: SIT)\n\ + \ doesKnowCommand: isHouseTrained(atOtherHomes: true)\n\ + \ }\n\ + \}" expected = Error { message = "Fields \"doesKnowCommand\" conflict because \ - \\"doesKnowCommand\" and \"isHousetrained\" are \ + \\"doesKnowCommand\" and \"isHouseTrained\" are \ \different fields. Use different aliases on the \ \fields to fetch both if this was intentional." , locations = [AST.Location 3 5, AST.Location 4 5] @@ -812,22 +766,20 @@ in validate queryString `shouldBe` [expected] it "looks for fields after a successfully merged field pair" $ - let queryString = [gql| - { - dog { - name - doesKnowCommand(dogCommand: SIT) - } - dog { - name - doesKnowCommand: isHousetrained(atOtherHomes: true) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ name\n\ + \ doesKnowCommand(dogCommand: SIT)\n\ + \ }\n\ + \ dog {\n\ + \ name\n\ + \ doesKnowCommand: isHouseTrained(atOtherHomes: true)\n\ + \ }\n\ + \}" expected = Error { message = "Fields \"doesKnowCommand\" conflict because \ - \\"doesKnowCommand\" and \"isHousetrained\" are \ + \\"doesKnowCommand\" and \"isHouseTrained\" are \ \different fields. Use different aliases on the \ \fields to fetch both if this was intentional." , locations = [AST.Location 4 5, AST.Location 8 5] @@ -836,15 +788,13 @@ context "possibleFragmentSpreadsRule" $ do it "rejects object inline spreads outside object scope" $ - let queryString = [gql| - { - dog { - ... on Cat { - meowVolume - } - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ... on Cat {\n\ + \ meowVolume\n\ + \ }\n\ + \ }\n\ + \}" expected = Error { message = "Fragment cannot be spread here as objects of type \ @@ -854,17 +804,15 @@ in validate queryString `shouldBe` [expected] it "rejects object named spreads outside object scope" $ - let queryString = [gql| - { - dog { - ... catInDogFragmentInvalid - } - } - - fragment catInDogFragmentInvalid on Cat { - meowVolume - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ ... catInDogFragmentInvalid\n\ + \ }\n\ + \}\n\ + \\n\ + \fragment catInDogFragmentInvalid on Cat {\n\ + \ meowVolume\n\ + \}" expected = Error { message = "Fragment \"catInDogFragmentInvalid\" cannot be \ @@ -876,13 +824,11 @@ context "providedRequiredInputFieldsRule" $ it "rejects missing required input fields" $ - let queryString = [gql| - { - findDog(complex: { name: null }) { - name - } - } - |] + let queryString = "{\n\ + \ findDog(complex: { name: null }) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Input field \"name\" of type \"DogData\" is \ @@ -893,13 +839,11 @@ context "providedRequiredArgumentsRule" $ do it "checks for (non-)nullable arguments" $ - let queryString = [gql| - { - dog { - doesKnowCommand(dogCommand: null) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ doesKnowCommand(dogCommand: null)\n\ + \ }\n\ + \}" expected = Error { message = "Field \"doesKnowCommand\" argument \"dogCommand\" \ @@ -911,13 +855,11 @@ context "variablesInAllowedPositionRule" $ do it "rejects wrongly typed variable arguments" $ - let queryString = [gql| - query dogCommandArgQuery($dogCommandArg: DogCommand) { - dog { - doesKnowCommand(dogCommand: $dogCommandArg) - } - } - |] + let queryString = "query dogCommandArgQuery($dogCommandArg: DogCommand) {\n\ + \ dog {\n\ + \ doesKnowCommand(dogCommand: $dogCommandArg)\n\ + \ }\n\ + \}" expected = Error { message = "Variable \"$dogCommandArg\" of type \ @@ -928,13 +870,11 @@ in validate queryString `shouldBe` [expected] it "rejects wrongly typed variable arguments" $ - let queryString = [gql| - query intCannotGoIntoBoolean($intArg: Int) { - dog { - isHousetrained(atOtherHomes: $intArg) - } - } - |] + let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: $intArg)\n\ + \ }\n\ + \}" expected = Error { message = "Variable \"$intArg\" of type \"Int\" used in \ @@ -945,13 +885,11 @@ context "valuesOfCorrectTypeRule" $ do it "rejects values of incorrect types" $ - let queryString = [gql| - { - dog { - isHousetrained(atOtherHomes: 3) - } - } - |] + let queryString = "{\n\ + \ dog {\n\ + \ isHouseTrained(atOtherHomes: 3)\n\ + \ }\n\ + \}" expected = Error { message = "Value 3 cannot be coerced to type \"Boolean\"." @@ -960,13 +898,11 @@ in validate queryString `shouldBe` [expected] it "uses the location of a single list value" $ - let queryString = [gql| - { - cat { - doesKnowCommands(catCommands: [3]) - } - } - |] + let queryString = "{\n\ + \ cat {\n\ + \ doesKnowCommands(catCommands: [3])\n\ + \ }\n\ + \}" expected = Error { message = "Value 3 cannot be coerced to type \"CatCommand!\"." @@ -975,13 +911,11 @@ in validate queryString `shouldBe` [expected] it "validates input object properties once" $ - let queryString = [gql| - { - findDog(complex: { name: 3 }) { - name - } - } - |] + let queryString = "{\n\ + \ findDog(complex: { name: 3 }) {\n\ + \ name\n\ + \ }\n\ + \}" expected = Error { message = "Value 3 cannot be coerced to type \"String!\"." @@ -990,13 +924,11 @@ in validate queryString `shouldBe` [expected] it "checks for required list members" $ - let queryString = [gql| - { - cat { - doesKnowCommands(catCommands: [null]) - } - } - |] + let queryString = "{\n\ + \ cat {\n\ + \ doesKnowCommands(catCommands: [null])\n\ + \ }\n\ + \}" expected = Error { message = "List of non-null values of type \"CatCommand\" \