diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,14 @@ 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 @@ ### 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 --- 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 implementation. category: Language @@ -40,7 +40,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 @@ -63,7 +62,6 @@ 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 @@ 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 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -482,12 +482,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 @@ -226,10 +226,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' 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 @@ -214,6 +214,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/TH.hs b/src/Language/GraphQL/TH.hs deleted file mode 100644 --- 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 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -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' _ -> 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 @@ -137,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 @@ -856,8 +859,8 @@ , "\"." ] --- | 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 @@ , "\"." ] --- | 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 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -181,7 +181,7 @@ 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 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -103,6 +103,12 @@ \ 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 --- 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 --- a/tests/Language/GraphQL/Validate/RulesSpec.hs +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -94,7 +94,7 @@ , ("nickname", nicknameResolver) , ("barkVolume", barkVolumeResolver) , ("doesKnowCommand", doesKnowCommandResolver) - , ("isHousetrained", isHousetrainedResolver) + , ("isHouseTrained", isHouseTrainedResolver) , ("owner", ownerResolver) ] where @@ -105,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 @@ -206,6 +206,18 @@ } 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ it "rejects unused variables" $ let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\ \ dog {\n\ - \ isHousetrained\n\ + \ isHouseTrained\n\ \ }\n\ \}" expected = Error @@ -648,7 +660,7 @@ 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 @@ 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 @@ 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 @@ \ }\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 @@ 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 @@ it "rejects values of incorrect types" $ let queryString = "{\n\ \ dog {\n\ - \ isHousetrained(atOtherHomes: 3)\n\ + \ isHouseTrained(atOtherHomes: 3)\n\ \ }\n\ \}" expected = Error