diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,13 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.2.0.2] - 2024-01-09 +### Fixed +- `gql` removes not only leading `\n` but also `\r`. +- Fix non nullable type string representation in executor error messages. +- Fix input objects not being coerced to lists. +- Fix used variables are not found in the properties of input objects. + ## [1.2.0.1] - 2023-04-25 ### Fixed - Support hspec 2.11. @@ -508,6 +515,7 @@ ### Added - Data types for the GraphQL language. +[1.2.0.2]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...v1.2.0.2 [1.2.0.1]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.0...v1.2.0.1 [1.2.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.1.0.0...v1.2.0.0 [1.1.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.3.0...v1.1.0.0 diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: graphql -version: 1.2.0.1 +version: 1.2.0.2 synopsis: Haskell GraphQL implementation description: Haskell implementation. category: Language @@ -11,7 +11,7 @@ Matthías Páll Gissurarson , Sólrún Halla Einarsdóttir maintainer: belka@caraus.de -copyright: (c) 2019-2023 Eugen Wissner, +copyright: (c) 2019-2024 Eugen Wissner, (c) 2015-2017 J. Daniel Navarro license: MPL-2.0 AND BSD-3-Clause license-files: LICENSE, @@ -21,7 +21,8 @@ CHANGELOG.md README.md tested-with: - GHC == 9.2.5 + GHC == 9.4.7, + GHC == 9.6.3 source-repository head type: git @@ -105,4 +106,6 @@ unordered-containers, containers, vector + build-tool-depends: + hspec-discover:hspec-discover default-language: Haskell2010 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 @@ -371,8 +371,8 @@ deriving Eq instance Show NonNullType where - show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName - show (NonNullTypeList listType) = concat ["![", show listType, "]"] + show (NonNullTypeNamed typeName) = Text.unpack $ typeName <> "!" + show (NonNullTypeList listType) = concat ["[", show listType, "]!"] -- ** Directives 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 @@ -556,8 +556,10 @@ $ Just inputValue | otherwise -> throwM $ InputCoercionException (Text.unpack argumentName) variableType Nothing + matchFieldValues' = matchFieldValues coerceArgumentValue $ Full.node <$> argumentValues + coerceArgumentValue inputType (Transform.Int integer) = coerceInputLiteral inputType (Type.Int integer) coerceArgumentValue inputType (Transform.Boolean boolean) = @@ -575,14 +577,31 @@ let coerceItem = coerceArgumentValue inputType in Type.List <$> traverse coerceItem list coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) - | In.InputObjectType _ _ inputFields <- inputType = + | In.InputObjectType _ _ inputFields <- inputType = let go = forEachField object resultMap = HashMap.foldrWithKey go (pure mempty) inputFields in Type.Object <$> resultMap coerceArgumentValue _ (Transform.Variable variable) = pure variable coerceArgumentValue _ _ = Nothing + coerceArgumentValue inputType transform = + coerceInputLiteral inputType $ extractArgumentValue transform +<<<<<<< Updated upstream + +======= forEachField object variableName (In.InputField _ variableType defaultValue) = matchFieldValues coerceArgumentValue object variableName variableType defaultValue +>>>>>>> Stashed changes + extractArgumentValue (Transform.Int integer) = Type.Int integer + extractArgumentValue (Transform.Boolean boolean) = Type.Boolean boolean + extractArgumentValue (Transform.String string) = Type.String string + extractArgumentValue (Transform.Float float) = Type.Float float + extractArgumentValue (Transform.Enum enum) = Type.Enum enum + extractArgumentValue Transform.Null = Type.Null + extractArgumentValue (Transform.List list) = + Type.List $ extractArgumentValue <$> list + extractArgumentValue (Transform.Object object) = + Type.Object $ extractArgumentValue <$> object + extractArgumentValue (Transform.Variable variable) = variable collectFields :: Monad m => Out.ObjectType m diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs --- a/src/Language/GraphQL/TH.hs +++ b/src/Language/GraphQL/TH.hs @@ -21,7 +21,7 @@ indent count (' ' : xs) = indent (count - 1) xs indent _ xs = xs withoutLeadingNewlines = dropNewlines code - dropNewlines = dropWhile (== '\n') + dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==) spaces = length $ takeWhile (== ' ') withoutLeadingNewlines -- | Removes leading and trailing newlines. Indentation of the first line is 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 @@ -18,6 +18,8 @@ , float , id , int + , showNonNullType + , showNonNullListType , selection , string ) where @@ -207,3 +209,11 @@ (Just (Boolean True)) -> Include directive' _ -> Skip include' directive' = Continue directive' + +showNonNullType :: Show a => a -> String +showNonNullType = (++ "!") . show + +showNonNullListType :: Show a => a -> String +showNonNullListType listType = + let representation = show listType + in concat ["[", representation, "]!"] 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 @@ -66,10 +66,11 @@ show (NamedEnumType enumType) = show enumType show (NamedInputObjectType inputObjectType) = show inputObjectType show (ListType baseType) = concat ["[", show baseType, "]"] - show (NonNullScalarType scalarType) = '!' : show scalarType - show (NonNullEnumType enumType) = '!' : show enumType - show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType - show (NonNullListType baseType) = concat ["![", show baseType, "]"] + show (NonNullScalarType scalarType) = Definition.showNonNullType scalarType + show (NonNullEnumType enumType) = Definition.showNonNullType enumType + show (NonNullInputObjectType inputObjectType) = + Definition.showNonNullType inputObjectType + show (NonNullListType baseType) = Definition.showNonNullListType baseType -- | Field argument definition. data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -115,12 +115,12 @@ show (NamedInterfaceType interfaceType) = show interfaceType show (NamedUnionType unionType) = show unionType show (ListType baseType) = concat ["[", show baseType, "]"] - show (NonNullScalarType scalarType) = '!' : show scalarType - show (NonNullEnumType enumType) = '!' : show enumType - show (NonNullObjectType inputObjectType) = '!' : show inputObjectType - show (NonNullInterfaceType interfaceType) = '!' : show interfaceType - show (NonNullUnionType unionType) = '!' : show unionType - show (NonNullListType baseType) = concat ["![", show baseType, "]"] + show (NonNullScalarType scalarType) = showNonNullType scalarType + show (NonNullEnumType enumType) = showNonNullType enumType + show (NonNullObjectType inputObjectType) = showNonNullType inputObjectType + show (NonNullInterfaceType interfaceType) = showNonNullType interfaceType + show (NonNullUnionType unionType) = showNonNullType unionType + show (NonNullListType baseType) = showNonNullListType baseType -- | Matches either 'NamedScalarType' or 'NonNullScalarType'. pattern ScalarBaseType :: forall m. ScalarType -> Type m 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 @@ -2,11 +2,13 @@ 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 DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -- | This module contains default rules defined in the GraphQL specification. @@ -61,6 +63,7 @@ import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text +import GHC.Records (HasField(..)) import qualified Language.GraphQL.AST.Document as Full import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Internal as Type @@ -618,6 +621,10 @@ , "\"." ] +-- Used to find the difference between defined and used variables. The first +-- argument are variables defined in the operation, the second argument are +-- variables used in the query. It should return the difference between these +-- 2 sets. type UsageDifference = HashMap Full.Name [Full.Location] -> HashMap Full.Name [Full.Location] @@ -664,11 +671,17 @@ = filterSelections' selections >>= lift . mapReaderT (<> mapDirectives directives') . pure findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments - mapArguments = Seq.fromList . mapMaybe findArgumentVariables + mapArguments = Seq.fromList . (>>= findArgumentVariables) mapDirectives = foldMap findDirectiveVariables - findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) = - Just (value', [location]) - findArgumentVariables _ = Nothing + + findArgumentVariables (Full.Argument _ value _) = findNodeVariables value + findNodeVariables Full.Node{ node = value, ..} = findValueVariables location value + + findValueVariables location (Full.Variable value') = [(value', [location])] + findValueVariables _ (Full.List values) = values >>= findNodeVariables + findValueVariables _ (Full.Object fields) = fields + >>= findNodeVariables . getField @"value" + findValueVariables _ _ = [] makeError operationName (variableName, locations') = Error { message = errorMessage operationName variableName , locations = locations' 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 @@ -69,6 +69,7 @@ , ("throwing", ValueResolver throwingField throwingResolver) , ("count", ValueResolver countField countResolver) , ("sequence", ValueResolver sequenceField sequenceResolver) + , ("withInputObject", ValueResolver withInputObjectField withInputObjectResolver) ] where philosopherField = @@ -89,7 +90,18 @@ let fieldType = Out.ListType $ Out.NonNullScalarType int in Out.Field Nothing fieldType HashMap.empty sequenceResolver = pure intSequence + withInputObjectResolver = pure $ Type.Int 0 + withInputObjectField = + Out.Field Nothing (Out.NonNullScalarType int) $ HashMap.fromList + [("values", In.Argument Nothing withInputObjectArgumentType Nothing)] + withInputObjectArgumentType = In.NonNullListType + $ In.NonNullInputObjectType inputObjectType +inputObjectType :: In.InputObjectType +inputObjectType = In.InputObjectType "InputObject" Nothing $ + HashMap.singleton "name" $ + In.InputField Nothing (In.NonNullScalarType int) Nothing + intSequence :: Value intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3] @@ -295,7 +307,7 @@ let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = - "Value completion error. Expected type !School, found: EXISTENTIALISM." + "Value completion error. Expected type School!, found: EXISTENTIALISM." , locations = [Location 1 17] , path = [Segment "philosopher", Segment "school"] } @@ -307,7 +319,7 @@ let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = - "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }." + "Value completion error. Expected type Interest!, found: { instrument: \"piano\" }." , locations = [Location 1 17] , path = [Segment "philosopher", Segment "interest"] } @@ -319,7 +331,7 @@ let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message - = "Value completion error. Expected type !Work, found:\ + = "Value completion error. Expected type Work!, found:\ \ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }." , locations = [Location 1 17] , path = [Segment "philosopher", Segment "majorWork"] @@ -328,22 +340,10 @@ sourceQuery = "{ philosopher { majorWork { title } } }" in sourceQuery `shouldResolveTo` expected - it "gives location information for invalid scalar arguments" $ - let data'' = Object $ HashMap.singleton "philosopher" Null - executionErrors = pure $ Error - { message = - "Argument \"id\" has invalid type. Expected type ID, found: True." - , locations = [Location 1 15] - , path = [Segment "philosopher"] - } - expected = Response data'' executionErrors - sourceQuery = "{ philosopher(id: true) { lastName } }" - in sourceQuery `shouldResolveTo` expected - it "gives location information for failed result coercion" $ let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error - { message = "Unable to coerce result to !Int." + { message = "Unable to coerce result to Int!." , locations = [Location 1 26] , path = [Segment "philosopher", Segment "century"] } @@ -364,7 +364,7 @@ it "sets data to null if a root field isn't nullable" $ let executionErrors = pure $ Error - { message = "Unable to coerce result to !Int." + { message = "Unable to coerce result to Int!." , locations = [Location 1 3] , path = [Segment "count"] } @@ -375,7 +375,7 @@ it "detects nullability errors" $ let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error - { message = "Value completion error. Expected type !String, found: null." + { message = "Value completion error. Expected type String!, found: null." , locations = [Location 1 26] , path = [Segment "philosopher", Segment "firstLanguage"] } @@ -388,6 +388,25 @@ expected = Response data'' mempty sourceQuery = "{ sequence }" in sourceQuery `shouldResolveTo` expected + + context "Arguments" $ do + it "gives location information for invalid scalar arguments" $ + let data'' = Object $ HashMap.singleton "philosopher" Null + executionErrors = pure $ Error + { message = + "Argument \"id\" has invalid type. Expected type ID, found: True." + , locations = [Location 1 15] + , path = [Segment "philosopher"] + } + expected = Response data'' executionErrors + sourceQuery = "{ philosopher(id: true) { lastName } }" + in sourceQuery `shouldResolveTo` expected + + it "puts an object in a list if needed" $ + let data'' = Object $ HashMap.singleton "withInputObject" $ Type.Int 0 + expected = Response data'' mempty + sourceQuery = "{ withInputObject(values: { name: 0 }) }" + in sourceQuery `shouldResolveTo` expected context "queryError" $ do let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }" 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 @@ -29,6 +29,7 @@ [ ("dog", dogResolver) , ("cat", catResolver) , ("findDog", findDogResolver) + , ("findCats", findCatsResolver) ] where dogField = Field Nothing (Out.NamedObjectType dogType) mempty @@ -39,6 +40,11 @@ findDogResolver = ValueResolver findDogField $ pure Null catField = Field Nothing (Out.NamedObjectType catType) mempty catResolver = ValueResolver catField $ pure Null + findCatsArguments = HashMap.singleton "commands" + $ In.Argument Nothing (In.NonNullListType $ In.NonNullEnumType catCommandType) + $ Just $ List [] + findCatsField = Field Nothing (Out.NonNullListType $ Out.NonNullObjectType catType) findCatsArguments + findCatsResolver = ValueResolver findCatsField $ pure $ List [] catCommandType :: EnumType catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList @@ -538,7 +544,7 @@ } in validate queryString `shouldContain` [expected] - context "noUndefinedVariablesRule" $ + context "noUndefinedVariablesRule" $ do it "rejects undefined variables" $ let queryString = [gql| query variableIsNotDefinedUsedInSingleFragment { @@ -560,7 +566,35 @@ } in validate queryString `shouldBe` [expected] - context "noUnusedVariablesRule" $ + it "gets variable location inside an input object" $ + let queryString = [gql| + query { + findDog (complex: { name: $name }) { + name + } + } + |] + expected = Error + { message = "Variable \"$name\" is not defined." + , locations = [AST.Location 2 29] + } + in validate queryString `shouldBe` [expected] + + it "gets variable location inside an array" $ + let queryString = [gql| + query { + findCats (commands: [JUMP, $command]) { + name + } + } + |] + expected = Error + { message = "Variable \"$command\" is not defined." + , locations = [AST.Location 2 30] + } + in validate queryString `shouldBe` [expected] + + context "noUnusedVariablesRule" $ do it "rejects unused variables" $ let queryString = [gql| query variableUnused($atOtherHomes: Boolean) { @@ -577,6 +611,16 @@ } 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 + } + } + |] + in validate queryString `shouldBe` [] + context "uniqueInputFieldNamesRule" $ it "rejects duplicate fields in input objects" $ let queryString = [gql| @@ -878,7 +922,7 @@ { message = "Variable \"$dogCommandArg\" of type \ \\"DogCommand\" used in position expecting type \ - \\"!DogCommand\"." + \\"DogCommand!\"." , locations = [AST.Location 1 26] } in validate queryString `shouldBe` [expected] @@ -925,7 +969,7 @@ |] expected = Error { message = - "Value 3 cannot be coerced to type \"!CatCommand\"." + "Value 3 cannot be coerced to type \"CatCommand!\"." , locations = [AST.Location 3 36] } in validate queryString `shouldBe` [expected] @@ -940,7 +984,7 @@ |] expected = Error { message = - "Value 3 cannot be coerced to type \"!String\"." + "Value 3 cannot be coerced to type \"String!\"." , locations = [AST.Location 2 28] } in validate queryString `shouldBe` [expected]