aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md9
-rw-r--r--graphql.cabal5
-rw-r--r--src/Language/GraphQL/AST/Document.hs9
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs3
-rw-r--r--src/Language/GraphQL/AST/Parser.hs1
-rw-r--r--src/Language/GraphQL/TH.hs48
-rw-r--r--src/Language/GraphQL/Validate.hs2
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs45
-rw-r--r--tests/Language/GraphQL/AST/EncoderSpec.hs2
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs6
-rw-r--r--tests/Language/GraphQL/THSpec.hs24
-rw-r--r--tests/Language/GraphQL/Validate/RulesSpec.hs48
12 files changed, 78 insertions, 124 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 3dda90c..afadd7a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,14 @@ The format is based on
and this project adheres to
[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
### Changed
- `Schema.Directive` is extended to contain a boolean argument, representing
@@ -538,6 +546,7 @@ and this project adheres to
### Added
- 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.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
diff --git a/graphql.cabal b/graphql.cabal
index 3ee6561..7088230 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -1,7 +1,7 @@
cabal-version: 3.0
name: graphql
-version: 1.4.0.0
+version: 1.5.0.0
synopsis: Haskell GraphQL implementation
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
category: Language
@@ -40,7 +40,6 @@ library
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
@@ -63,7 +62,6 @@ library
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,
@@ -84,7 +82,6 @@ test-suite graphql-test
Language.GraphQL.Execute.CoerceSpec
Language.GraphQL.Execute.OrderedMapSpec
Language.GraphQL.ExecuteSpec
- Language.GraphQL.THSpec
Language.GraphQL.Type.OutSpec
Language.GraphQL.Validate.RulesSpec
Schemas.HeroSchema
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 101cf78..11317d8 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -482,12 +482,9 @@ instance Monoid Description
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
index a1076e4..603023b 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -226,10 +226,11 @@ typeDefinition formatter = \case
<> 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'
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index f325ee7..d3a6b34 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -214,6 +214,7 @@ interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
<$ symbol "interface"
<*> name
+ <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives
<*> braces (many fieldDefinition)
<?> "InterfaceTypeDefinition"
diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs
deleted file mode 100644
index 22ffdd0..0000000
--- a/src/Language/GraphQL/TH.hs
+++ /dev/null
@@ -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)"
- }
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 5feb85a..1d24523 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -210,7 +210,7 @@ typeDefinition context rule = \case
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' _ ->
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 3fef94d..1c202fe 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -137,25 +137,28 @@ singleFieldSubscriptionsRule :: forall m. Rule m
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
@@ -856,8 +859,8 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
, "\"."
]
--- | 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
@@ -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
--- that the server has declared support for.
+-- that the service has declared support for.
directivesInValidLocationsRule :: Rule m
directivesInValidLocationsRule = DirectivesRule directivesRule
where
diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs
index e98d5ef..82d059a 100644
--- a/tests/Language/GraphQL/AST/EncoderSpec.hs
+++ b/tests/Language/GraphQL/AST/EncoderSpec.hs
@@ -181,7 +181,7 @@ spec = do
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 = "interface UUID {\n\
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index 3bd2576..9f992bb 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -103,6 +103,12 @@ spec = describe "Parser" $ do
\ 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`
"enum Direction {\n\
diff --git a/tests/Language/GraphQL/THSpec.hs b/tests/Language/GraphQL/THSpec.hs
deleted file mode 100644
index 2858ab2..0000000
--- a/tests/Language/GraphQL/THSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs
index c48b329..9ec74c3 100644
--- a/tests/Language/GraphQL/Validate/RulesSpec.hs
+++ b/tests/Language/GraphQL/Validate/RulesSpec.hs
@@ -94,7 +94,7 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
, ("nickname", nicknameResolver)
, ("barkVolume", barkVolumeResolver)
, ("doesKnowCommand", doesKnowCommandResolver)
- , ("isHousetrained", isHousetrainedResolver)
+ , ("isHouseTrained", isHouseTrainedResolver)
, ("owner", ownerResolver)
]
where
@@ -105,10 +105,10 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
$ 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
@@ -206,6 +206,18 @@ spec =
}
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" $
let queryString = "subscription sub {\n\
\ ...multipleSubscriptions\n\
@@ -455,7 +467,7 @@ spec =
it "rejects duplicate field arguments" $
let queryString = "{\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: true, atOtherHomes: true)\n\
+ \ isHouseTrained(atOtherHomes: true, atOtherHomes: true)\n\
\ }\n\
\}"
expected = Error
@@ -492,7 +504,7 @@ spec =
it "rejects duplicate variables" $
let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: $atOtherHomes)\n\
+ \ isHouseTrained(atOtherHomes: $atOtherHomes)\n\
\ }\n\
\}"
expected = Error
@@ -507,7 +519,7 @@ spec =
it "rejects non-input types as variables" $
let queryString = "query takesDogBang($dog: Dog!) {\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: $dog)\n\
+ \ isHouseTrained(atOtherHomes: $dog)\n\
\ }\n\
\}"
expected = Error
@@ -522,12 +534,12 @@ spec =
it "rejects undefined variables" $
let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\
\ dog {\n\
- \ ...isHousetrainedFragment\n\
+ \ ...isHouseTrainedFragment\n\
\ }\n\
\}\n\
\\n\
- \fragment isHousetrainedFragment on Dog {\n\
- \ isHousetrained(atOtherHomes: $atOtherHomes)\n\
+ \fragment isHouseTrainedFragment on Dog {\n\
+ \ isHouseTrained(atOtherHomes: $atOtherHomes)\n\
\}"
expected = Error
{ message =
@@ -566,7 +578,7 @@ spec =
it "rejects unused variables" $
let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\
\ dog {\n\
- \ isHousetrained\n\
+ \ isHouseTrained\n\
\ }\n\
\}"
expected = Error
@@ -648,7 +660,7 @@ spec =
it "rejects directive arguments missing in the definition" $
let queryString = "{\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: true) @include(unless: false, if: true)\n\
+ \ isHouseTrained(atOtherHomes: true) @include(unless: false, if: true)\n\
\ }\n\
\}"
expected = Error
@@ -663,7 +675,7 @@ spec =
it "rejects undefined directives" $
let queryString = "{\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: true) @ignore(if: true)\n\
+ \ isHouseTrained(atOtherHomes: true) @ignore(if: true)\n\
\ }\n\
\}"
expected = Error
@@ -740,13 +752,13 @@ spec =
let queryString = "{\n\
\ dog {\n\
\ doesKnowCommand(dogCommand: SIT)\n\
- \ doesKnowCommand: isHousetrained(atOtherHomes: true)\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]
@@ -761,13 +773,13 @@ spec =
\ }\n\
\ dog {\n\
\ name\n\
- \ doesKnowCommand: isHousetrained(atOtherHomes: true)\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]
@@ -860,7 +872,7 @@ spec =
it "rejects wrongly typed variable arguments" $
let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: $intArg)\n\
+ \ isHouseTrained(atOtherHomes: $intArg)\n\
\ }\n\
\}"
expected = Error
@@ -875,7 +887,7 @@ spec =
it "rejects values of incorrect types" $
let queryString = "{\n\
\ dog {\n\
- \ isHousetrained(atOtherHomes: 3)\n\
+ \ isHouseTrained(atOtherHomes: 3)\n\
\ }\n\
\}"
expected = Error
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 07:23:56 +0000