Compare commits

...

8 Commits

Author SHA1 Message Date
497edf326d
Add --enable-tests to test
All checks were successful
Build / audit (push) Successful in 16s
Build / test (push) Successful in 6m26s
Build / doc (push) Successful in 5m23s
2025-01-18 16:54:11 +01:00
663e4f3521
Make the lexer and parser safe
Some checks failed
Build / audit (push) Has been cancelled
Build / test (push) Has been cancelled
Build / doc (push) Has been cancelled
2025-01-18 16:33:13 +01:00
324a4c55ff
Release 1.5.0.0
All checks were successful
Build / audit (push) Successful in 17s
Build / test (push) Successful in 6m27s
Build / doc (push) Successful in 5m32s
Release / release (push) Successful in 5s
2024-12-03 19:49:33 +01:00
7ea76865e6
Validate the subscription root
All checks were successful
Build / audit (push) Successful in 17s
Build / test (push) Successful in 6m33s
Build / doc (push) Successful in 5m45s
…not to be an introspection field.
2024-12-01 21:53:01 +01:00
2dcefff76a
Add test for introspection as subscription root
All checks were successful
Build / audit (push) Successful in 18s
Build / test (push) Successful in 6m19s
Build / doc (push) Successful in 5m30s
Add a pending test checking that an introspection field cannot be
subscription root.
2024-11-10 22:23:54 +01:00
27a5a0b44e
Adjust wording according to the 2021 specification
All checks were successful
Build / audit (push) Successful in 17s
Build / test (push) Successful in 6m33s
Build / doc (push) Successful in 5m37s
2024-11-07 18:18:12 +01:00
97627ffc36
Parse interfaces implementing interfaces
All checks were successful
Build / audit (push) Successful in 18s
Build / test (push) Successful in 6m30s
Build / doc (push) Successful in 5m36s
2024-11-05 19:44:45 +01:00
6f7bb10a62
Remove deprecated gql quasi quoter 2024-11-05 19:39:16 +01:00
19 changed files with 102 additions and 149 deletions

View File

@ -21,8 +21,8 @@ jobs:
- name: Install dependencies - name: Install dependencies
run: cabal update run: cabal update
- name: Prepare system - name: Prepare system
run: cabal build graphql-test run: cabal build graphql-test --enable-tests
- run: cabal test --test-show-details=streaming - run: cabal test --test-show-details=streaming --enable-tests
doc: doc:
runs-on: buildenv runs-on: buildenv

View File

@ -6,6 +6,14 @@ The format is based on
and this project adheres to and this project adheres to
[Haskell Package Versioning Policy](https://pvp.haskell.org/). [Haskell Package Versioning Policy](https://pvp.haskell.org/).
## [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 ## [1.4.0.0] - 2024-10-26
### Changed ### Changed
- `Schema.Directive` is extended to contain a boolean argument, representing - `Schema.Directive` is extended to contain a boolean argument, representing
@ -538,6 +546,7 @@ and this project adheres to
### Added ### Added
- Data types for the GraphQL language. - Data types for the GraphQL language.
[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.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.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.3]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.2...v1.2.0.3

View File

@ -1,7 +1,7 @@
cabal-version: 3.0 cabal-version: 3.0
name: graphql name: graphql
version: 1.4.0.0 version: 1.5.0.0
synopsis: Haskell GraphQL implementation synopsis: Haskell GraphQL implementation
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
category: Language category: Language
@ -11,7 +11,7 @@ author: Danny Navarro <j@dannynavarro.net>,
Matthías Páll Gissurarson <mpg@mpg.is>, Matthías Páll Gissurarson <mpg@mpg.is>,
Sólrún Halla Einarsdóttir <she@mpg.is> Sólrún Halla Einarsdóttir <she@mpg.is>
maintainer: belka@caraus.de maintainer: belka@caraus.de
copyright: (c) 2019-2024 Eugen Wissner, copyright: (c) 2019-2025 Eugen Wissner,
(c) 2015-2017 J. Daniel Navarro (c) 2015-2017 J. Daniel Navarro
license: MPL-2.0 AND BSD-3-Clause license: MPL-2.0 AND BSD-3-Clause
license-files: LICENSE, license-files: LICENSE,
@ -21,7 +21,7 @@ extra-source-files:
CHANGELOG.md CHANGELOG.md
README.md README.md
tested-with: tested-with:
GHC == 9.8.2 GHC == 9.10.1
source-repository head source-repository head
type: git type: git
@ -40,7 +40,6 @@ library
Language.GraphQL.Execute Language.GraphQL.Execute
Language.GraphQL.Execute.Coerce Language.GraphQL.Execute.Coerce
Language.GraphQL.Execute.OrderedMap Language.GraphQL.Execute.OrderedMap
Language.GraphQL.TH
Language.GraphQL.Type Language.GraphQL.Type
Language.GraphQL.Type.In Language.GraphQL.Type.In
Language.GraphQL.Type.Out Language.GraphQL.Type.Out
@ -63,7 +62,6 @@ library
exceptions ^>= 0.10.4, exceptions ^>= 0.10.4,
megaparsec >= 9.0 && < 10, megaparsec >= 9.0 && < 10,
parser-combinators >= 1.3 && < 2, parser-combinators >= 1.3 && < 2,
template-haskell >= 2.16 && < 3,
text >= 1.2 && < 3, text >= 1.2 && < 3,
transformers >= 0.5.6 && < 0.7, transformers >= 0.5.6 && < 0.7,
unordered-containers ^>= 0.2.14, unordered-containers ^>= 0.2.14,
@ -84,7 +82,6 @@ test-suite graphql-test
Language.GraphQL.Execute.CoerceSpec Language.GraphQL.Execute.CoerceSpec
Language.GraphQL.Execute.OrderedMapSpec Language.GraphQL.Execute.OrderedMapSpec
Language.GraphQL.ExecuteSpec Language.GraphQL.ExecuteSpec
Language.GraphQL.THSpec
Language.GraphQL.Type.OutSpec Language.GraphQL.Type.OutSpec
Language.GraphQL.Validate.RulesSpec Language.GraphQL.Validate.RulesSpec
Schemas.HeroSchema Schemas.HeroSchema

View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
-- | Target AST for parser. -- | Target AST for parser.

View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
-- | Various parts of a GraphQL document can be annotated with directives. -- | Various parts of a GraphQL document can be annotated with directives.

View File

@ -3,6 +3,7 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It -- | This module defines an abstract syntax tree for the @GraphQL@ language. It
@ -482,12 +483,9 @@ instance Monoid Description
data TypeDefinition data TypeDefinition
= ScalarTypeDefinition Description Name [Directive] = ScalarTypeDefinition Description Name [Directive]
| ObjectTypeDefinition | ObjectTypeDefinition
Description Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
Name | InterfaceTypeDefinition
(ImplementsInterfaces []) Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
[Directive]
[FieldDefinition]
| InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
| UnionTypeDefinition Description Name [Directive] (UnionMemberTypes []) | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
| EnumTypeDefinition Description Name [Directive] [EnumValueDefinition] | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
| InputObjectTypeDefinition | InputObjectTypeDefinition

View File

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
-- | This module defines a minifier and a printer for the @GraphQL@ language. -- | This module defines a minifier and a printer for the @GraphQL@ language.
@ -226,10 +227,11 @@ typeDefinition formatter = \case
<> optempty (directives formatter) directives' <> optempty (directives formatter) directives'
<> eitherFormat formatter " " "" <> eitherFormat formatter " " ""
<> bracesList formatter (fieldDefinition nextFormatter) fields' <> bracesList formatter (fieldDefinition nextFormatter) fields'
Full.InterfaceTypeDefinition description' name' directives' fields' Full.InterfaceTypeDefinition description' name' ifaces' directives' fields'
-> optempty (description formatter) description' -> optempty (description formatter) description'
<> "interface " <> "interface "
<> Lazy.Text.fromStrict name' <> Lazy.Text.fromStrict name'
<> optempty (" " <>) (implementsInterfaces ifaces')
<> optempty (directives formatter) directives' <> optempty (directives formatter) directives'
<> eitherFormat formatter " " "" <> eitherFormat formatter " " ""
<> bracesList formatter (fieldDefinition nextFormatter) fields' <> bracesList formatter (fieldDefinition nextFormatter) fields'

View File

@ -1,5 +1,7 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
-- | This module defines a bunch of small parsers used to parse individual -- | This module defines a bunch of small parsers used to parse individual
-- lexemes. -- lexemes.

View File

@ -2,6 +2,8 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
-- | @GraphQL@ document parser. -- | @GraphQL@ document parser.
module Language.GraphQL.AST.Parser module Language.GraphQL.AST.Parser
@ -214,6 +216,7 @@ interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description' interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
<$ symbol "interface" <$ symbol "interface"
<*> name <*> name
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives <*> directives
<*> braces (many fieldDefinition) <*> braces (many fieldDefinition)
<?> "InterfaceTypeDefinition" <?> "InterfaceTypeDefinition"

View File

@ -189,6 +189,8 @@ data QueryError
| CoercionError Full.VariableDefinition | CoercionError Full.VariableDefinition
| UnknownInputType Full.VariableDefinition | UnknownInputType Full.VariableDefinition
type ExecuteHandler m a e = e -> ExecutorT m a
tell :: Monad m => Seq Error -> ExecutorT m () tell :: Monad m => Seq Error -> ExecutorT m ()
tell = ExecutorT . lift . Writer.tell tell = ExecutorT . lift . Writer.tell
@ -313,8 +315,7 @@ executeQuery topSelections schema = do
pure $ Response data' errors pure $ Response data' errors
handleException :: (MonadCatch m, Serialize a) handleException :: (MonadCatch m, Serialize a)
=> FieldException => ExecuteHandler m a FieldException
-> ExecutorT m a
handleException (FieldException fieldLocation errorPath next) = handleException (FieldException fieldLocation errorPath next) =
let newError = constructError next fieldLocation errorPath let newError = constructError next fieldLocation errorPath
in tell (Seq.singleton newError) >> pure null in tell (Seq.singleton newError) >> pure null
@ -390,30 +391,28 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
fieldErrorPath = fieldsSegment fields : errorPath fieldErrorPath = fieldsSegment fields : errorPath
inputCoercionHandler :: (MonadCatch m, Serialize a) inputCoercionHandler :: (MonadCatch m, Serialize a)
=> Full.Location => Full.Location
-> InputCoercionException -> ExecuteHandler m a InputCoercionException
-> ExecutorT m a
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
let argumentLocation = getField @"location" valueNode let argumentLocation = getField @"location" valueNode
in exceptionHandler argumentLocation e in exceptionHandler argumentLocation e
inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
resultHandler :: (MonadCatch m, Serialize a) resultHandler :: (MonadCatch m, Serialize a)
=> Full.Location => Full.Location
-> ResultException -> ExecuteHandler m a ResultException
-> ExecutorT m a
resultHandler = exceptionHandler resultHandler = exceptionHandler
resolverHandler :: (MonadCatch m, Serialize a) resolverHandler :: (MonadCatch m, Serialize a)
=> Full.Location => Full.Location
-> ResolverException -> ExecuteHandler m a ResolverException
-> ExecutorT m a
resolverHandler = exceptionHandler resolverHandler = exceptionHandler
nullResultHandler :: (MonadCatch m, Serialize a) nullResultHandler :: (MonadCatch m, Serialize a) => ExecuteHandler m a FieldException
=> FieldException
-> ExecutorT m a
nullResultHandler e@(FieldException fieldLocation errorPath' next) = nullResultHandler e@(FieldException fieldLocation errorPath' next) =
let newError = constructError next fieldLocation errorPath' let newError = constructError next fieldLocation errorPath'
in if Out.isNonNullType fieldType in if Out.isNonNullType fieldType
then throwM e then throwM e
else returnError newError else returnError newError
exceptionHandler :: (Exception e, MonadCatch m, Serialize a)
=> Full.Location
-> ExecuteHandler m a e
exceptionHandler errorLocation e = exceptionHandler errorLocation e =
let newError = constructError e errorLocation fieldErrorPath let newError = constructError e errorLocation fieldErrorPath
in if Out.isNonNullType fieldType in if Out.isNonNullType fieldType

View File

@ -1,48 +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
$ dropWhile isLineBreak
$ reverse
$ unlines
$ indent spaces <$> lines' withoutLeadingNewlines
where
indent 0 xs = xs
indent count (' ' : xs) = indent (count - 1) xs
indent _ xs = xs
withoutLeadingNewlines = dropWhile isLineBreak code
spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
lines' "" = []
lines' string =
let (line, rest) = break isLineBreak string
reminder =
case rest of
[] -> []
'\r' : '\n' : strippedString -> lines' strippedString
_ : strippedString -> lines' strippedString
in line : reminder
isLineBreak = flip any ['\n', '\r'] . (==)
-- | Removes leading and trailing newlines. Indentation of the first line is
-- removed from each line of the string.
{-# DEPRECATED gql "Use Language.GraphQL.Class.gql from graphql-spice instead" #-}
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)"
}

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
-- | Types that can be used as both input and output types. -- | Types that can be used as both input and output types.

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}

View File

@ -210,7 +210,7 @@ typeDefinition context rule = \case
Full.ObjectTypeDefinition _ _ _ directives' fields Full.ObjectTypeDefinition _ _ _ directives' fields
-> directives context rule objectLocation directives' -> directives context rule objectLocation directives'
>< foldMap (fieldDefinition context rule) fields >< foldMap (fieldDefinition context rule) fields
Full.InterfaceTypeDefinition _ _ directives' fields Full.InterfaceTypeDefinition _ _ _ directives' fields
-> directives context rule interfaceLocation directives' -> directives context rule interfaceLocation directives'
>< foldMap (fieldDefinition context rule) fields >< foldMap (fieldDefinition context rule) fields
Full.UnionTypeDefinition _ _ directives' _ -> Full.UnionTypeDefinition _ _ directives' _ ->

View File

@ -137,25 +137,28 @@ singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
case HashSet.size groupedFieldSet of case HashSet.toList groupedFieldSet of
1 -> lift mempty [rootName]
_ | Text.isPrefixOf "__" rootName -> makeError location' name'
| Just name <- name' -> pure $ Error "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
makeError location' (Just operationName) errorLine = pure $ Error
{ message = concat { message = concat
[ "Subscription \"" [ "Subscription \""
, Text.unpack name , Text.unpack operationName
, "\" must select only one top level field." , "\" must select "
, errorLine
] ]
, locations = [location'] , locations = [location']
} }
| otherwise -> pure $ Error makeError location' Nothing errorLine = pure $ Error
{ message = errorMessage { message = "Anonymous Subscription must select " <> errorLine
, locations = [location'] , locations = [location']
} }
_ -> lift mempty
where
errorMessage =
"Anonymous Subscription must select only one top level field."
collectFields = foldM forEach HashSet.empty collectFields = foldM forEach HashSet.empty
forEach accumulator = \case forEach accumulator = \case
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
@ -856,8 +859,8 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
, "\"." , "\"."
] ]
-- | GraphQL servers define what directives they support. For each usage of a -- | GraphQL services define what directives they support. For each usage of a
-- directive, the directive must be available on that server. -- directive, the directive must be available on that service.
knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule :: Rule m
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
definitions' <- asks $ Schema.directives . schema definitions' <- asks $ Schema.directives . schema
@ -909,9 +912,9 @@ knownInputFieldNamesRule = ValueRule go constGo
, "\"." , "\"."
] ]
-- | 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 -- 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 :: Rule m
directivesInValidLocationsRule = DirectivesRule directivesRule directivesInValidLocationsRule = DirectivesRule directivesRule
where where
@ -1064,18 +1067,12 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
go selectionSet selectionType = do go selectionSet selectionType = do
fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty
fieldsInSetCanMerge fieldTuples fieldsInSetCanMerge fieldTuples
fieldsInSetCanMerge :: forall m
. HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
-> ReaderT (Validation m) Seq Error
fieldsInSetCanMerge fieldTuples = do fieldsInSetCanMerge fieldTuples = do
validation <- ask validation <- ask
let (lonely, paired) = flattenPairs fieldTuples let (lonely, paired) = flattenPairs fieldTuples
let reader = flip runReaderT validation let reader = flip runReaderT validation
lift $ foldMap (reader . visitLonelyFields) lonely lift $ foldMap (reader . visitLonelyFields) lonely
<> foldMap (reader . forEachFieldTuple) paired <> foldMap (reader . forEachFieldTuple) paired
forEachFieldTuple :: forall m
. (FieldInfo m, FieldInfo m)
-> ReaderT (Validation m) Seq Error
forEachFieldTuple (fieldA, fieldB) = forEachFieldTuple (fieldA, fieldB) =
case (parent fieldA, parent fieldB) of case (parent fieldA, parent fieldB) of
(parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{}) (parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{})
@ -1102,10 +1099,6 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
let Full.Field _ _ _ _ subSelections _ = node let Full.Field _ _ _ _ subSelections _ = node
compositeFieldType = Type.outToComposite type' compositeFieldType = Type.outToComposite type'
in maybe (lift Seq.empty) (go subSelections) compositeFieldType in maybe (lift Seq.empty) (go subSelections) compositeFieldType
sameResponseShape :: forall m
. FieldInfo m
-> FieldInfo m
-> ReaderT (Validation m) Seq Error
sameResponseShape fieldA fieldB = sameResponseShape fieldA fieldB =
let Full.Field _ _ _ _ selectionsA _ = node fieldA let Full.Field _ _ _ _ selectionsA _ = node fieldA
Full.Field _ _ _ _ selectionsB _ = node fieldB Full.Field _ _ _ _ selectionsB _ = node fieldB

View File

@ -181,7 +181,7 @@ spec = do
argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
arguments = Full.ArgumentsDefinition [argument] arguments = Full.ArgumentsDefinition [argument]
definition' = Full.TypeDefinition definition' = Full.TypeDefinition
$ Full.InterfaceTypeDefinition mempty "UUID" mempty $ Full.InterfaceTypeDefinition mempty "UUID" (Full.ImplementsInterfaces []) mempty
$ pure $ pure
$ Full.FieldDefinition mempty "value" arguments someType mempty $ Full.FieldDefinition mempty "value" arguments someType mempty
expected = "interface UUID {\n\ expected = "interface UUID {\n\

View File

@ -103,6 +103,12 @@ spec = describe "Parser" $ do
\ name: String\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" $ it "parses minimal enum type definition" $
parse document "" `shouldSucceedOn` parse document "" `shouldSucceedOn`
"enum Direction {\n\ "enum Direction {\n\

View File

@ -1,24 +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 QuasiQuotes #-}
module Language.GraphQL.THSpec
( spec
) where
import Language.GraphQL.TH (gql)
import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec
spec =
describe "gql" $
it "replaces CRNL with NL" $
let expected = "line1\nline2\nline3"
actual = [gql|
line1
line2
line3
|]
in actual `shouldBe` expected

View File

@ -94,7 +94,7 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
, ("nickname", nicknameResolver) , ("nickname", nicknameResolver)
, ("barkVolume", barkVolumeResolver) , ("barkVolume", barkVolumeResolver)
, ("doesKnowCommand", doesKnowCommandResolver) , ("doesKnowCommand", doesKnowCommandResolver)
, ("isHousetrained", isHousetrainedResolver) , ("isHouseTrained", isHouseTrainedResolver)
, ("owner", ownerResolver) , ("owner", ownerResolver)
] ]
where where
@ -105,10 +105,10 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
$ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
doesKnowCommandResolver = ValueResolver doesKnowCommandField doesKnowCommandResolver = ValueResolver doesKnowCommandField
$ pure $ Boolean True $ pure $ Boolean True
isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean) isHouseTrainedField = Field Nothing (Out.NonNullScalarType boolean)
$ HashMap.singleton "atOtherHomes" $ HashMap.singleton "atOtherHomes"
$ In.Argument Nothing (In.NamedScalarType boolean) Nothing $ In.Argument Nothing (In.NamedScalarType boolean) Nothing
isHousetrainedResolver = ValueResolver isHousetrainedField isHouseTrainedResolver = ValueResolver isHouseTrainedField
$ pure $ Boolean True $ pure $ Boolean True
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
ownerResolver = ValueResolver ownerField $ pure Null ownerResolver = ValueResolver ownerField $ pure Null
@ -206,6 +206,18 @@ spec =
} }
in validate queryString `shouldContain` [expected] in validate queryString `shouldContain` [expected]
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]
it "rejects multiple subscription root fields coming from a fragment" $ it "rejects multiple subscription root fields coming from a fragment" $
let queryString = "subscription sub {\n\ let queryString = "subscription sub {\n\
\ ...multipleSubscriptions\n\ \ ...multipleSubscriptions\n\
@ -455,7 +467,7 @@ spec =
it "rejects duplicate field arguments" $ it "rejects duplicate field arguments" $
let queryString = "{\n\ let queryString = "{\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: true, atOtherHomes: true)\n\ \ isHouseTrained(atOtherHomes: true, atOtherHomes: true)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -492,7 +504,7 @@ spec =
it "rejects duplicate variables" $ it "rejects duplicate variables" $
let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\ let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: $atOtherHomes)\n\ \ isHouseTrained(atOtherHomes: $atOtherHomes)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -507,7 +519,7 @@ spec =
it "rejects non-input types as variables" $ it "rejects non-input types as variables" $
let queryString = "query takesDogBang($dog: Dog!) {\n\ let queryString = "query takesDogBang($dog: Dog!) {\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: $dog)\n\ \ isHouseTrained(atOtherHomes: $dog)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -522,12 +534,12 @@ spec =
it "rejects undefined variables" $ it "rejects undefined variables" $
let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\ let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\
\ dog {\n\ \ dog {\n\
\ ...isHousetrainedFragment\n\ \ ...isHouseTrainedFragment\n\
\ }\n\ \ }\n\
\}\n\ \}\n\
\\n\ \\n\
\fragment isHousetrainedFragment on Dog {\n\ \fragment isHouseTrainedFragment on Dog {\n\
\ isHousetrained(atOtherHomes: $atOtherHomes)\n\ \ isHouseTrained(atOtherHomes: $atOtherHomes)\n\
\}" \}"
expected = Error expected = Error
{ message = { message =
@ -566,7 +578,7 @@ spec =
it "rejects unused variables" $ it "rejects unused variables" $
let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\ let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained\n\ \ isHouseTrained\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -648,7 +660,7 @@ spec =
it "rejects directive arguments missing in the definition" $ it "rejects directive arguments missing in the definition" $
let queryString = "{\n\ let queryString = "{\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: true) @include(unless: false, if: true)\n\ \ isHouseTrained(atOtherHomes: true) @include(unless: false, if: true)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -663,7 +675,7 @@ spec =
it "rejects undefined directives" $ it "rejects undefined directives" $
let queryString = "{\n\ let queryString = "{\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: true) @ignore(if: true)\n\ \ isHouseTrained(atOtherHomes: true) @ignore(if: true)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -740,13 +752,13 @@ spec =
let queryString = "{\n\ let queryString = "{\n\
\ dog {\n\ \ dog {\n\
\ doesKnowCommand(dogCommand: SIT)\n\ \ doesKnowCommand(dogCommand: SIT)\n\
\ doesKnowCommand: isHousetrained(atOtherHomes: true)\n\ \ doesKnowCommand: isHouseTrained(atOtherHomes: true)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
{ message = { message =
"Fields \"doesKnowCommand\" conflict because \ "Fields \"doesKnowCommand\" conflict because \
\\"doesKnowCommand\" and \"isHousetrained\" are \ \\"doesKnowCommand\" and \"isHouseTrained\" are \
\different fields. Use different aliases on the \ \different fields. Use different aliases on the \
\fields to fetch both if this was intentional." \fields to fetch both if this was intentional."
, locations = [AST.Location 3 5, AST.Location 4 5] , locations = [AST.Location 3 5, AST.Location 4 5]
@ -761,13 +773,13 @@ spec =
\ }\n\ \ }\n\
\ dog {\n\ \ dog {\n\
\ name\n\ \ name\n\
\ doesKnowCommand: isHousetrained(atOtherHomes: true)\n\ \ doesKnowCommand: isHouseTrained(atOtherHomes: true)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
{ message = { message =
"Fields \"doesKnowCommand\" conflict because \ "Fields \"doesKnowCommand\" conflict because \
\\"doesKnowCommand\" and \"isHousetrained\" are \ \\"doesKnowCommand\" and \"isHouseTrained\" are \
\different fields. Use different aliases on the \ \different fields. Use different aliases on the \
\fields to fetch both if this was intentional." \fields to fetch both if this was intentional."
, locations = [AST.Location 4 5, AST.Location 8 5] , locations = [AST.Location 4 5, AST.Location 8 5]
@ -860,7 +872,7 @@ spec =
it "rejects wrongly typed variable arguments" $ it "rejects wrongly typed variable arguments" $
let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\ let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: $intArg)\n\ \ isHouseTrained(atOtherHomes: $intArg)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error
@ -875,7 +887,7 @@ spec =
it "rejects values of incorrect types" $ it "rejects values of incorrect types" $
let queryString = "{\n\ let queryString = "{\n\
\ dog {\n\ \ dog {\n\
\ isHousetrained(atOtherHomes: 3)\n\ \ isHouseTrained(atOtherHomes: 3)\n\
\ }\n\ \ }\n\
\}" \}"
expected = Error expected = Error