Compare commits

..

7 Commits

13 changed files with 192 additions and 103 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]
### 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.
## [1.2.0.1] - 2023-04-25
### Fixed

View File

@ -21,8 +21,8 @@ extra-source-files:
CHANGELOG.md
README.md
tested-with:
GHC == 9.2.8,
GHC == 9.6.2
GHC == 9.4.7,
GHC == 9.6.3
source-repository head
type: git
@ -85,7 +85,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
@ -107,4 +106,6 @@ test-suite graphql-test
unordered-containers,
containers,
vector
build-tool-depends:
hspec-discover:hspec-discover
default-language: Haskell2010

View File

@ -371,8 +371,8 @@ data NonNullType
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

View File

@ -556,33 +556,24 @@ coerceArgumentValues argumentDefinitions argumentValues =
$ 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) =
coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (Transform.String string) =
coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Transform.Float float) =
coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Transform.Enum enum) =
coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Transform.Null
| In.isNonNullType inputType = Nothing
| otherwise = coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
let coerceItem = coerceArgumentValue inputType
in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
| 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
forEachField object variableName (In.InputField _ variableType defaultValue) =
matchFieldValues coerceArgumentValue object variableName variableType defaultValue
coerceArgumentValue inputType transform =
coerceInputLiteral inputType $ extractArgumentValue transform
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

View File

@ -12,26 +12,17 @@ import Language.Haskell.TH (Exp(..), Lit(..))
stripIndentation :: String -> String
stripIndentation code = reverse
$ dropWhile isLineBreak
$ dropNewlines
$ reverse
$ unlines
$ indent spaces <$> lines' withoutLeadingNewlines
$ indent spaces <$> lines withoutLeadingNewlines
where
indent 0 xs = xs
indent count (' ' : xs) = indent (count - 1) xs
indent _ xs = xs
withoutLeadingNewlines = dropWhile isLineBreak code
withoutLeadingNewlines = dropNewlines code
dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==)
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.

View File

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

View File

@ -66,10 +66,11 @@ instance Show Type where
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)

View File

@ -115,12 +115,12 @@ instance forall a. Show (Type a) where
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

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
= HashMap Full.Name [Full.Location]
-> HashMap Full.Name [Full.Location]
@ -664,11 +668,26 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
= 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 _ Full.Node{node = value, ..} _) =
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
{ message = errorMessage operationName variableName
, locations = locations'

View File

@ -69,6 +69,7 @@ queryType = Out.ObjectType "Query" Nothing []
, ("throwing", ValueResolver throwingField throwingResolver)
, ("count", ValueResolver countField countResolver)
, ("sequence", ValueResolver sequenceField sequenceResolver)
, ("withInputObject", ValueResolver withInputObjectField withInputObjectResolver)
]
where
philosopherField =
@ -89,6 +90,17 @@ queryType = Out.ObjectType "Query" Nothing []
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 @@ spec =
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 @@ spec =
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 @@ spec =
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 @@ spec =
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 @@ spec =
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 @@ spec =
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"]
}
@ -389,6 +389,25 @@ spec =
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 } }"
twoQueries = namedQuery "A" <> " " <> namedQuery "B"

View File

@ -1,23 +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"
actual = [gql|
line1
line2
|]
in actual `shouldBe` expected

View File

@ -18,7 +18,7 @@ import Language.GraphQL.Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
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)
petSchema :: Schema IO
@ -560,7 +560,7 @@ spec =
}
in validate queryString `shouldBe` [expected]
context "noUnusedVariablesRule" $
context "noUnusedVariablesRule" $ do
it "rejects unused variables" $
let queryString = [gql|
query variableUnused($atOtherHomes: Boolean) {
@ -577,6 +577,16 @@ spec =
}
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" $
it "rejects duplicate fields in input objects" $
let queryString = [gql|
@ -878,7 +888,7 @@ spec =
{ 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 +935,7 @@ spec =
|]
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 +950,7 @@ spec =
|]
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]