graphql 1.4.0.0 → 1.5.0.0
raw patch · 12 files changed
+78/−124 lines, 12 filesdep −template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies removed: template-haskell
API changes (from Hackage documentation)
- Language.GraphQL.TH: gql :: QuasiQuoter
- Language.GraphQL.AST.Document: InterfaceTypeDefinition :: Description -> Name -> [Directive] -> [FieldDefinition] -> TypeDefinition
+ Language.GraphQL.AST.Document: InterfaceTypeDefinition :: Description -> Name -> ImplementsInterfaces [] -> [Directive] -> [FieldDefinition] -> TypeDefinition
Files
- CHANGELOG.md +9/−0
- graphql.cabal +1/−4
- src/Language/GraphQL/AST/Document.hs +3/−6
- src/Language/GraphQL/AST/Encoder.hs +2/−1
- src/Language/GraphQL/AST/Parser.hs +1/−0
- src/Language/GraphQL/TH.hs +0/−48
- src/Language/GraphQL/Validate.hs +1/−1
- src/Language/GraphQL/Validate/Rules.hs +24/−21
- tests/Language/GraphQL/AST/EncoderSpec.hs +1/−1
- tests/Language/GraphQL/AST/ParserSpec.hs +6/−0
- tests/Language/GraphQL/THSpec.hs +0/−24
- tests/Language/GraphQL/Validate/RulesSpec.hs +30/−18
CHANGELOG.md view
@@ -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
graphql.cabal view
@@ -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 @@ 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
src/Language/GraphQL/AST/Document.hs view
@@ -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
src/Language/GraphQL/AST/Encoder.hs view
@@ -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'
src/Language/GraphQL/AST/Parser.hs view
@@ -214,6 +214,7 @@ interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description' <$ symbol "interface" <*> name+ <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> directives <*> braces (many fieldDefinition) <?> "InterfaceTypeDefinition"
− src/Language/GraphQL/TH.hs
@@ -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)"- }
src/Language/GraphQL/Validate.hs view
@@ -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' _ ->
src/Language/GraphQL/Validate/Rules.hs view
@@ -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
tests/Language/GraphQL/AST/EncoderSpec.hs view
@@ -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\
tests/Language/GraphQL/AST/ParserSpec.hs view
@@ -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\
− tests/Language/GraphQL/THSpec.hs
@@ -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
tests/Language/GraphQL/Validate/RulesSpec.hs view
@@ -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