Compare commits

..

7 Commits

10 changed files with 170 additions and 41 deletions

View File

@ -0,0 +1,68 @@
name: Build
on:
push:
pull_request:
branches: [master]
jobs:
audit:
runs-on: alpine
steps:
- name: Set up environment
shell: ash {0}
run: |
apk add --no-cache git bash curl build-base readline-dev openssl-dev zlib-dev libpq-dev gmp-dev
- name: Prepare system
run: |
curl --create-dirs --output-dir \
~/.ghcup/bin https://downloads.haskell.org/~ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 -o ghcup
chmod +x ~/.ghcup/bin/ghcup
~/.ghcup/bin/ghcup install ghc 9.4.8
~/.ghcup/bin/ghcup install cabal 3.6.2.0
- uses: actions/checkout@v4
- name: Install dependencies
run: |
~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal update
~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal install hlint --constraint="hlint ==3.6.1"
- run: ~/.cabal/bin/hlint -- src tests
test:
runs-on: alpine
steps:
- name: Set up environment
shell: ash {0}
run: |
apk add --no-cache git bash curl build-base readline-dev openssl-dev zlib-dev libpq-dev gmp-dev
- name: Prepare system
run: |
curl --create-dirs --output-dir \
~/.ghcup/bin https://downloads.haskell.org/~ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 -o ghcup
chmod +x ~/.ghcup/bin/ghcup
~/.ghcup/bin/ghcup install ghc 9.4.8
~/.ghcup/bin/ghcup install cabal 3.6.2.0
- uses: actions/checkout@v4
- name: Install dependencies
run: |
~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal update
~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal build graphql-test
- run: ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal test --test-show-details=direct
doc:
runs-on: alpine
steps:
- name: Set up environment
shell: ash {0}
run: |
apk add --no-cache git bash curl build-base readline-dev openssl-dev zlib-dev libpq-dev gmp-dev
- name: Prepare system
run: |
curl --create-dirs --output-dir \
~/.ghcup/bin https://downloads.haskell.org/~ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 -o ghcup
chmod +x ~/.ghcup/bin/ghcup
~/.ghcup/bin/ghcup install ghc 9.4.8
~/.ghcup/bin/ghcup install cabal 3.6.2.0
- uses: actions/checkout@v4
- name: Install dependencies
run: ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal update
- run: ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal haddock --enable-documentation

View File

@ -9,6 +9,8 @@ and this project adheres to
## [Unreleased] ## [Unreleased]
### Fixed ### Fixed
- `gql` removes not only leading `\n` but also `\r`. - `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.
## [1.2.0.1] - 2023-04-25 ## [1.2.0.1] - 2023-04-25
### Fixed ### Fixed

View File

@ -21,8 +21,8 @@ extra-source-files:
CHANGELOG.md CHANGELOG.md
README.md README.md
tested-with: tested-with:
GHC == 9.2.8, GHC == 9.4.7,
GHC == 9.6.2 GHC == 9.6.3
source-repository head source-repository head
type: git type: git

View File

@ -371,8 +371,8 @@ data NonNullType
deriving Eq deriving Eq
instance Show NonNullType where instance Show NonNullType where
show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName show (NonNullTypeNamed typeName) = Text.unpack $ typeName <> "!"
show (NonNullTypeList listType) = concat ["![", show listType, "]"] show (NonNullTypeList listType) = concat ["[", show listType, "]!"]
-- ** Directives -- ** Directives

View File

@ -18,6 +18,8 @@ module Language.GraphQL.Type.Definition
, float , float
, id , id
, int , int
, showNonNullType
, showNonNullListType
, selection , selection
, string , string
) where ) where
@ -207,3 +209,11 @@ include = handle include'
(Just (Boolean True)) -> Include directive' (Just (Boolean True)) -> Include directive'
_ -> Skip _ -> Skip
include' directive' = Continue directive' 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, "]!"]

View File

@ -66,10 +66,11 @@ instance Show Type where
show (NamedEnumType enumType) = show enumType show (NamedEnumType enumType) = show enumType
show (NamedInputObjectType inputObjectType) = show inputObjectType show (NamedInputObjectType inputObjectType) = show inputObjectType
show (ListType baseType) = concat ["[", show baseType, "]"] show (ListType baseType) = concat ["[", show baseType, "]"]
show (NonNullScalarType scalarType) = '!' : show scalarType show (NonNullScalarType scalarType) = Definition.showNonNullType scalarType
show (NonNullEnumType enumType) = '!' : show enumType show (NonNullEnumType enumType) = Definition.showNonNullType enumType
show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType show (NonNullInputObjectType inputObjectType) =
show (NonNullListType baseType) = concat ["![", show baseType, "]"] Definition.showNonNullType inputObjectType
show (NonNullListType baseType) = Definition.showNonNullListType baseType
-- | Field argument definition. -- | Field argument definition.
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)

View File

@ -115,12 +115,12 @@ instance forall a. Show (Type a) where
show (NamedInterfaceType interfaceType) = show interfaceType show (NamedInterfaceType interfaceType) = show interfaceType
show (NamedUnionType unionType) = show unionType show (NamedUnionType unionType) = show unionType
show (ListType baseType) = concat ["[", show baseType, "]"] show (ListType baseType) = concat ["[", show baseType, "]"]
show (NonNullScalarType scalarType) = '!' : show scalarType show (NonNullScalarType scalarType) = showNonNullType scalarType
show (NonNullEnumType enumType) = '!' : show enumType show (NonNullEnumType enumType) = showNonNullType enumType
show (NonNullObjectType inputObjectType) = '!' : show inputObjectType show (NonNullObjectType inputObjectType) = showNonNullType inputObjectType
show (NonNullInterfaceType interfaceType) = '!' : show interfaceType show (NonNullInterfaceType interfaceType) = showNonNullType interfaceType
show (NonNullUnionType unionType) = '!' : show unionType show (NonNullUnionType unionType) = showNonNullType unionType
show (NonNullListType baseType) = concat ["![", show baseType, "]"] show (NonNullListType baseType) = showNonNullListType baseType
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'. -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
pattern ScalarBaseType :: forall m. ScalarType -> Type m pattern ScalarBaseType :: forall m. ScalarType -> Type m

View File

@ -618,6 +618,10 @@ noUndefinedVariablesRule =
, "\"." , "\"."
] ]
-- 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 type UsageDifference
= HashMap Full.Name [Full.Location] = HashMap Full.Name [Full.Location]
-> HashMap Full.Name [Full.Location] -> HashMap Full.Name [Full.Location]
@ -664,11 +668,26 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
= filterSelections' selections = filterSelections' selections
>>= lift . mapReaderT (<> mapDirectives directives') . pure >>= lift . mapReaderT (<> mapDirectives directives') . pure
findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
mapArguments = Seq.fromList . mapMaybe findArgumentVariables
mapArguments = Seq.fromList . (>>= findArgumentVariables)
mapDirectives = foldMap findDirectiveVariables mapDirectives = foldMap findDirectiveVariables
findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
Just (value', [location]) findArgumentVariables (Full.Argument _ Full.Node{node = value, ..} _) =
findArgumentVariables _ = Nothing findValueVariables location value
findValueVariables location (Full.Variable value') = [(value', [location])]
findValueVariables location (Full.List values) =
values
>>= (\(Full.Node{node = value}) -> findValueVariables location value)
findValueVariables _ (Full.Object fields) =
fields
>>= ( \( Full.ObjectField
{ location = location
, value = Full.Node{node = value}
}
) -> findValueVariables location value
)
findValueVariables _ _ = []
makeError operationName (variableName, locations') = Error makeError operationName (variableName, locations') = Error
{ message = errorMessage operationName variableName { message = errorMessage operationName variableName
, locations = locations' , locations = locations'

View File

@ -69,6 +69,7 @@ queryType = Out.ObjectType "Query" Nothing []
, ("throwing", ValueResolver throwingField throwingResolver) , ("throwing", ValueResolver throwingField throwingResolver)
, ("count", ValueResolver countField countResolver) , ("count", ValueResolver countField countResolver)
, ("sequence", ValueResolver sequenceField sequenceResolver) , ("sequence", ValueResolver sequenceField sequenceResolver)
, ("withInputObject", ValueResolver withInputObjectField withInputObjectResolver)
] ]
where where
philosopherField = philosopherField =
@ -89,6 +90,17 @@ queryType = Out.ObjectType "Query" Nothing []
let fieldType = Out.ListType $ Out.NonNullScalarType int let fieldType = Out.ListType $ Out.NonNullScalarType int
in Out.Field Nothing fieldType HashMap.empty in Out.Field Nothing fieldType HashMap.empty
sequenceResolver = pure intSequence 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 :: Value
intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3] intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3]
@ -295,7 +307,7 @@ spec =
let data'' = Object $ HashMap.singleton "philosopher" Null let data'' = Object $ HashMap.singleton "philosopher" Null
executionErrors = pure $ Error executionErrors = pure $ Error
{ message = { message =
"Value completion error. Expected type !School, found: EXISTENTIALISM." "Value completion error. Expected type School!, found: EXISTENTIALISM."
, locations = [Location 1 17] , locations = [Location 1 17]
, path = [Segment "philosopher", Segment "school"] , path = [Segment "philosopher", Segment "school"]
} }
@ -307,7 +319,7 @@ spec =
let data'' = Object $ HashMap.singleton "philosopher" Null let data'' = Object $ HashMap.singleton "philosopher" Null
executionErrors = pure $ Error executionErrors = pure $ Error
{ message = { message =
"Value completion error. Expected type !Interest, found: { instrument: \"piano\" }." "Value completion error. Expected type Interest!, found: { instrument: \"piano\" }."
, locations = [Location 1 17] , locations = [Location 1 17]
, path = [Segment "philosopher", Segment "interest"] , path = [Segment "philosopher", Segment "interest"]
} }
@ -319,7 +331,7 @@ spec =
let data'' = Object $ HashMap.singleton "philosopher" Null let data'' = Object $ HashMap.singleton "philosopher" Null
executionErrors = pure $ Error executionErrors = pure $ Error
{ message { 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\" }." \ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }."
, locations = [Location 1 17] , locations = [Location 1 17]
, path = [Segment "philosopher", Segment "majorWork"] , path = [Segment "philosopher", Segment "majorWork"]
@ -328,22 +340,10 @@ spec =
sourceQuery = "{ philosopher { majorWork { title } } }" sourceQuery = "{ philosopher { majorWork { title } } }"
in sourceQuery `shouldResolveTo` expected 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" $ it "gives location information for failed result coercion" $
let data'' = Object $ HashMap.singleton "philosopher" Null let data'' = Object $ HashMap.singleton "philosopher" Null
executionErrors = pure $ Error executionErrors = pure $ Error
{ message = "Unable to coerce result to !Int." { message = "Unable to coerce result to Int!."
, locations = [Location 1 26] , locations = [Location 1 26]
, path = [Segment "philosopher", Segment "century"] , path = [Segment "philosopher", Segment "century"]
} }
@ -364,7 +364,7 @@ spec =
it "sets data to null if a root field isn't nullable" $ it "sets data to null if a root field isn't nullable" $
let executionErrors = pure $ Error let executionErrors = pure $ Error
{ message = "Unable to coerce result to !Int." { message = "Unable to coerce result to Int!."
, locations = [Location 1 3] , locations = [Location 1 3]
, path = [Segment "count"] , path = [Segment "count"]
} }
@ -375,7 +375,7 @@ spec =
it "detects nullability errors" $ it "detects nullability errors" $
let data'' = Object $ HashMap.singleton "philosopher" Null let data'' = Object $ HashMap.singleton "philosopher" Null
executionErrors = pure $ Error 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] , locations = [Location 1 26]
, path = [Segment "philosopher", Segment "firstLanguage"] , path = [Segment "philosopher", Segment "firstLanguage"]
} }
@ -389,6 +389,25 @@ spec =
sourceQuery = "{ sequence }" sourceQuery = "{ sequence }"
in sourceQuery `shouldResolveTo` expected 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 context "queryError" $ do
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }" let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
twoQueries = namedQuery "A" <> " " <> namedQuery "B" twoQueries = namedQuery "A" <> " " <> namedQuery "B"

View File

@ -18,7 +18,7 @@ import Language.GraphQL.Type
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Validate import Language.GraphQL.Validate
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain, xit)
import Text.Megaparsec (parse, errorBundlePretty) import Text.Megaparsec (parse, errorBundlePretty)
petSchema :: Schema IO petSchema :: Schema IO
@ -560,7 +560,7 @@ spec =
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
context "noUnusedVariablesRule" $ context "noUnusedVariablesRule" $ do
it "rejects unused variables" $ it "rejects unused variables" $
let queryString = [gql| let queryString = [gql|
query variableUnused($atOtherHomes: Boolean) { query variableUnused($atOtherHomes: Boolean) {
@ -577,6 +577,16 @@ spec =
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
xit "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" $ context "uniqueInputFieldNamesRule" $
it "rejects duplicate fields in input objects" $ it "rejects duplicate fields in input objects" $
let queryString = [gql| let queryString = [gql|
@ -878,7 +888,7 @@ spec =
{ message = { message =
"Variable \"$dogCommandArg\" of type \ "Variable \"$dogCommandArg\" of type \
\\"DogCommand\" used in position expecting type \ \\"DogCommand\" used in position expecting type \
\\"!DogCommand\"." \\"DogCommand!\"."
, locations = [AST.Location 1 26] , locations = [AST.Location 1 26]
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
@ -925,7 +935,7 @@ spec =
|] |]
expected = Error expected = Error
{ message = { message =
"Value 3 cannot be coerced to type \"!CatCommand\"." "Value 3 cannot be coerced to type \"CatCommand!\"."
, locations = [AST.Location 3 36] , locations = [AST.Location 3 36]
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
@ -940,7 +950,7 @@ spec =
|] |]
expected = Error expected = Error
{ message = { message =
"Value 3 cannot be coerced to type \"!String\"." "Value 3 cannot be coerced to type \"String!\"."
, locations = [AST.Location 2 28] , locations = [AST.Location 2 28]
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]