forked from OSS/graphql
Compare commits
26 Commits
feature/rn
...
master
Author | SHA1 | Date | |
---|---|---|---|
1834e5c41e | |||
01b30a71da | |||
b40d8a7e1e | |||
4b5e25a4d8 | |||
a4e648d5aa | |||
6e32112be4 | |||
388af30b51 | |||
e02463f452 | |||
9d85379826 | |||
9b11300d23 | |||
1c4584abdd | |||
e071553e75 | |||
e731c7db07 | |||
303cf18d77 | |||
6b8346e527 | |||
303f84ed41 | |||
d2ea9fb467 | |||
809f446ff1 | |||
b1b6bfcdb9 | |||
59aa010f0b | |||
b1c5a568dd | |||
5ffe8c72fa | |||
a961b168db | |||
a1cda38e20 | |||
7c78497e04 | |||
fdc43e4e25 |
3
.gitea/deploy.awk
Normal file
3
.gitea/deploy.awk
Normal file
@ -0,0 +1,3 @@
|
||||
END {
|
||||
system("cabal upload --username belka --password "ENVIRON["HACKAGE_PASSWORD"]" "$0)
|
||||
}
|
33
.gitea/workflows/build.yml
Normal file
33
.gitea/workflows/build.yml
Normal file
@ -0,0 +1,33 @@
|
||||
name: Build
|
||||
|
||||
on:
|
||||
push:
|
||||
branches:
|
||||
- '**'
|
||||
pull_request:
|
||||
branches: [master]
|
||||
|
||||
jobs:
|
||||
audit:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- run: hlint -- src tests
|
||||
|
||||
test:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: cabal update
|
||||
- name: Prepare system
|
||||
run: cabal build graphql-test
|
||||
- run: cabal test --test-show-details=streaming
|
||||
|
||||
doc:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Install dependencies
|
||||
run: cabal update
|
||||
- run: cabal haddock --enable-documentation
|
17
.gitea/workflows/release.yml
Normal file
17
.gitea/workflows/release.yml
Normal file
@ -0,0 +1,17 @@
|
||||
name: Release
|
||||
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- '**'
|
||||
|
||||
jobs:
|
||||
release:
|
||||
runs-on: buildenv
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Upload a candidate
|
||||
env:
|
||||
HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }}
|
||||
run: |
|
||||
cabal sdist | awk -f .gitea/deploy.awk
|
28
CHANGELOG.md
28
CHANGELOG.md
@ -7,8 +7,31 @@ and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
### Changed
|
||||
- `Schema.Directive` is extended to contain a boolean argument, representing
|
||||
repeatable directives. The parser can parse repeatable directive definitions.
|
||||
|
||||
### Fixed
|
||||
- `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).
|
||||
|
||||
### Added
|
||||
- @specifiedBy directive.
|
||||
|
||||
## [1.3.0.0] - 2024-05-01
|
||||
### Changed
|
||||
- Remove deprecated `runCollectErrs`, `Resolution`, `CollectErrsT` from the
|
||||
`Error` module.
|
||||
|
||||
## [1.2.0.3] - 2024-01-09
|
||||
### Fixed
|
||||
- Fix corrupted source distribution.
|
||||
|
||||
## [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
|
||||
@ -512,7 +535,10 @@ and this project adheres to
|
||||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[Unreleased]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...master
|
||||
[Unreleased]: https://git.caraus.tech/OSS/graphql/compare/v1.3.0.0...master
|
||||
[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
|
||||
[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
|
||||
|
@ -1,7 +1,7 @@
|
||||
cabal-version: 2.4
|
||||
cabal-version: 3.0
|
||||
|
||||
name: graphql
|
||||
version: 1.2.0.1
|
||||
version: 1.3.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
@ -11,7 +11,7 @@ author: Danny Navarro <j@dannynavarro.net>,
|
||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
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,8 +21,7 @@ extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
tested-with:
|
||||
GHC == 9.2.8,
|
||||
GHC == 9.6.2
|
||||
GHC == 9.8.2
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
@ -58,9 +57,9 @@ library
|
||||
ghc-options: -Wall
|
||||
|
||||
build-depends:
|
||||
base >= 4.7 && < 5,
|
||||
base >= 4.15 && < 5,
|
||||
conduit ^>= 1.3.4,
|
||||
containers ^>= 0.6.2,
|
||||
containers >= 0.6 && < 0.8,
|
||||
exceptions ^>= 0.10.4,
|
||||
megaparsec >= 9.0 && < 10,
|
||||
parser-combinators >= 1.3 && < 2,
|
||||
@ -85,6 +84,7 @@ 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
|
||||
@ -93,7 +93,7 @@ test-suite graphql-test
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||
|
||||
build-depends:
|
||||
QuickCheck ^>= 2.14.1,
|
||||
QuickCheck >= 2.14 && < 2.16,
|
||||
base,
|
||||
conduit,
|
||||
exceptions,
|
||||
@ -106,4 +106,6 @@ test-suite graphql-test
|
||||
unordered-containers,
|
||||
containers,
|
||||
vector
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
default-language: Haskell2010
|
||||
|
@ -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
|
||||
|
||||
@ -405,7 +405,7 @@ data TypeSystemDefinition
|
||||
= SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
|
||||
| TypeDefinition TypeDefinition
|
||||
| DirectiveDefinition
|
||||
Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
|
||||
Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Type System Extensions
|
||||
|
@ -159,11 +159,12 @@ typeSystemDefinition formatter = \case
|
||||
<> optempty (directives formatter) operationDirectives
|
||||
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
||||
Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
|
||||
Full.DirectiveDefinition description' name' arguments' locations
|
||||
Full.DirectiveDefinition description' name' arguments' repeatable locations
|
||||
-> description formatter description'
|
||||
<> "@"
|
||||
<> Lazy.Text.fromStrict name'
|
||||
<> argumentsDefinition formatter arguments'
|
||||
<> (if repeatable then " repeatable" else mempty)
|
||||
<> " on"
|
||||
<> pipeList formatter (directiveLocation <$> locations)
|
||||
|
||||
|
@ -29,7 +29,8 @@ module Language.GraphQL.AST.Lexer
|
||||
, unicodeBOM
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..), liftA2)
|
||||
import Control.Applicative (Alternative(..))
|
||||
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||
import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
|
||||
import Data.Foldable (foldl')
|
||||
import Data.List (dropWhileEnd)
|
||||
@ -37,22 +38,22 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec ( Parsec
|
||||
, (<?>)
|
||||
, between
|
||||
, chunk
|
||||
, chunkToTokens
|
||||
, notFollowedBy
|
||||
, oneOf
|
||||
, option
|
||||
, optional
|
||||
, satisfy
|
||||
, sepBy
|
||||
, skipSome
|
||||
, takeP
|
||||
, takeWhile1P
|
||||
, try
|
||||
)
|
||||
import Text.Megaparsec
|
||||
( Parsec
|
||||
, (<?>)
|
||||
, between
|
||||
, chunk
|
||||
, chunkToTokens
|
||||
, notFollowedBy
|
||||
, oneOf
|
||||
, option
|
||||
, optional
|
||||
, satisfy
|
||||
, skipSome
|
||||
, takeP
|
||||
, takeWhile1P
|
||||
, try
|
||||
)
|
||||
import Text.Megaparsec.Char (char, digitChar, space1)
|
||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||
import Data.Text (Text)
|
||||
@ -142,12 +143,13 @@ blockString :: Parser T.Text
|
||||
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
||||
where
|
||||
stringValue = do
|
||||
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
||||
let indentSize = foldr countIndent 0 $ tail byLine
|
||||
withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
|
||||
byLine <- NonEmpty.sepBy1 (many blockStringCharacter) lineTerminator
|
||||
let indentSize = foldr countIndent 0 $ NonEmpty.tail byLine
|
||||
withoutIndent = NonEmpty.head byLine
|
||||
: (removeIndent indentSize <$> NonEmpty.tail byLine)
|
||||
withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
|
||||
|
||||
return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
||||
pure $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
||||
removeEmptyLine [] = True
|
||||
removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
|
||||
removeEmptyLine _ = False
|
||||
@ -180,10 +182,10 @@ name :: Parser T.Text
|
||||
name = do
|
||||
firstLetter <- nameFirstLetter
|
||||
rest <- many $ nameFirstLetter <|> digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
||||
where
|
||||
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
||||
void spaceConsumer
|
||||
pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
||||
where
|
||||
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
||||
|
||||
isChunkDelimiter :: Char -> Bool
|
||||
isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
|
||||
@ -197,25 +199,25 @@ lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
|
||||
isSourceCharacter :: Char -> Bool
|
||||
isSourceCharacter = isSourceCharacter' . ord
|
||||
where
|
||||
isSourceCharacter' code = code >= 0x0020
|
||||
|| code == 0x0009
|
||||
|| code == 0x000a
|
||||
|| code == 0x000d
|
||||
isSourceCharacter' code
|
||||
= code >= 0x0020
|
||||
|| elem code [0x0009, 0x000a, 0x000d]
|
||||
|
||||
escapeSequence :: Parser Char
|
||||
escapeSequence = do
|
||||
_ <- char '\\'
|
||||
void $ char '\\'
|
||||
escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
|
||||
case escaped of
|
||||
'b' -> return '\b'
|
||||
'f' -> return '\f'
|
||||
'n' -> return '\n'
|
||||
'r' -> return '\r'
|
||||
't' -> return '\t'
|
||||
'u' -> chr . foldl' step 0
|
||||
. chunkToTokens (Proxy :: Proxy T.Text)
|
||||
<$> takeP Nothing 4
|
||||
_ -> return escaped
|
||||
'b' -> pure '\b'
|
||||
'f' -> pure '\f'
|
||||
'n' -> pure '\n'
|
||||
'r' -> pure '\r'
|
||||
't' -> pure '\t'
|
||||
'u' -> chr
|
||||
. foldl' step 0
|
||||
. chunkToTokens (Proxy :: Proxy T.Text)
|
||||
<$> takeP Nothing 4
|
||||
_ -> pure escaped
|
||||
where
|
||||
step accumulator = (accumulator * 16 +) . digitToInt
|
||||
|
||||
|
@ -8,7 +8,7 @@ module Language.GraphQL.AST.Parser
|
||||
( document
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..), liftA2, optional)
|
||||
import Control.Applicative (Alternative(..), optional)
|
||||
import Control.Applicative.Combinators (sepBy1)
|
||||
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
@ -27,6 +27,7 @@ import Text.Megaparsec
|
||||
, unPos
|
||||
, (<?>)
|
||||
)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
-- | Parser for the GraphQL documents.
|
||||
document :: Parser Full.Document
|
||||
@ -82,6 +83,7 @@ directiveDefinition description' = Full.DirectiveDefinition description'
|
||||
<* at
|
||||
<*> name
|
||||
<*> argumentsDefinition
|
||||
<*> (isJust <$> optional (symbol "repeatable"))
|
||||
<* symbol "on"
|
||||
<*> directiveLocations
|
||||
<?> "DirectiveDefinition"
|
||||
|
@ -8,28 +8,22 @@
|
||||
|
||||
-- | Error handling.
|
||||
module Language.GraphQL.Error
|
||||
( CollectErrsT
|
||||
, Error(..)
|
||||
( Error(..)
|
||||
, Path(..)
|
||||
, Resolution(..)
|
||||
, ResolverException(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, parseError
|
||||
, runCollectErrs
|
||||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Trans.State (StateT, runStateT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Location(..), Name)
|
||||
import Language.GraphQL.AST (Location(..))
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec
|
||||
( ParseErrorBundle(..)
|
||||
@ -97,28 +91,3 @@ instance Show ResolverException where
|
||||
show (ResolverException e) = show e
|
||||
|
||||
instance Exception ResolverException
|
||||
|
||||
-- * Deprecated
|
||||
|
||||
{-# DEPRECATED runCollectErrs "runCollectErrs was part of the old executor and isn't used anymore" #-}
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
=> HashMap Name (Schema.Type m)
|
||||
-> CollectErrsT m a
|
||||
-> m (Response a)
|
||||
runCollectErrs types' res = do
|
||||
(dat, Resolution{..}) <- runStateT res
|
||||
$ Resolution{ errors = Seq.empty, types = types' }
|
||||
pure $ Response dat errors
|
||||
|
||||
{-# DEPRECATED Resolution "Resolution was part of the old executor and isn't used anymore" #-}
|
||||
-- | Executor context.
|
||||
data Resolution m = Resolution
|
||||
{ errors :: Seq Error
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
}
|
||||
|
||||
{-# DEPRECATED CollectErrsT "CollectErrsT was part of the old executor and isn't used anymore" #-}
|
||||
-- | A wrapper to pass error messages around.
|
||||
type CollectErrsT m = StateT (Resolution m) m
|
||||
|
@ -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
|
||||
|
@ -12,17 +12,26 @@ import Language.Haskell.TH (Exp(..), Lit(..))
|
||||
|
||||
stripIndentation :: String -> String
|
||||
stripIndentation code = reverse
|
||||
$ dropNewlines
|
||||
$ dropWhile isLineBreak
|
||||
$ 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 = dropNewlines code
|
||||
dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==)
|
||||
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.
|
||||
|
@ -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, "]!"]
|
||||
|
@ -66,13 +66,15 @@ 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)
|
||||
deriving Eq
|
||||
|
||||
-- | Field argument definitions.
|
||||
type Arguments = HashMap Name Argument
|
||||
|
@ -48,7 +48,11 @@ data Type m
|
||||
deriving Eq
|
||||
|
||||
-- | Directive definition.
|
||||
data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
|
||||
--
|
||||
-- A definition consists of an optional description, arguments, whether the
|
||||
-- directive is repeatable, and the allowed directive locations.
|
||||
data Directive = Directive (Maybe Text) In.Arguments Bool [DirectiveLocation]
|
||||
deriving Eq
|
||||
|
||||
-- | Directive definitions.
|
||||
type Directives = HashMap Full.Name Directive
|
||||
|
@ -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
|
||||
|
@ -85,15 +85,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
||||
[ ("skip", skipDirective)
|
||||
, ("include", includeDirective)
|
||||
, ("deprecated", deprecatedDirective)
|
||||
, ("specifiedBy", specifiedByDirective)
|
||||
]
|
||||
includeDirective =
|
||||
Directive includeDescription skipIncludeLocations includeArguments
|
||||
Directive includeDescription includeArguments False skipIncludeLocations
|
||||
includeArguments = HashMap.singleton "if"
|
||||
$ In.Argument (Just "Included when true.") ifType Nothing
|
||||
includeDescription = Just
|
||||
"Directs the executor to include this field or fragment only when the \
|
||||
\`if` argument is true."
|
||||
skipDirective = Directive skipDescription skipIncludeLocations skipArguments
|
||||
skipDirective = Directive skipDescription skipArguments False skipIncludeLocations
|
||||
skipArguments = HashMap.singleton "if"
|
||||
$ In.Argument (Just "skipped when true.") ifType Nothing
|
||||
ifType = In.NonNullScalarType Definition.boolean
|
||||
@ -106,16 +107,15 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
||||
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
||||
]
|
||||
deprecatedDirective =
|
||||
Directive deprecatedDescription deprecatedLocations deprecatedArguments
|
||||
Directive deprecatedDescription deprecatedArguments False deprecatedLocations
|
||||
reasonDescription = Just
|
||||
"Explains why this element was deprecated, usually also including a \
|
||||
\suggestion for how to access supported similar data. Formatted using \
|
||||
\the Markdown syntax, as specified by \
|
||||
\[CommonMark](https://commonmark.org/).'"
|
||||
deprecatedArguments = HashMap.singleton "reason"
|
||||
$ In.Argument reasonDescription reasonType
|
||||
$ In.Argument reasonDescription (In.NamedScalarType Definition.string)
|
||||
$ Just "No longer supported"
|
||||
reasonType = In.NamedScalarType Definition.string
|
||||
deprecatedDescription = Just
|
||||
"Marks an element of a GraphQL schema as no longer supported."
|
||||
deprecatedLocations =
|
||||
@ -124,6 +124,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.EnumValue
|
||||
]
|
||||
specifiedByDirective =
|
||||
Directive specifiedByDescription specifiedByArguments False specifiedByLocations
|
||||
urlDescription = Just
|
||||
"The URL that specifies the behavior of this scalar."
|
||||
specifiedByArguments = HashMap.singleton "url"
|
||||
$ In.Argument urlDescription (In.NonNullScalarType Definition.string) Nothing
|
||||
specifiedByDescription = Just
|
||||
"Exposes a URL that specifies the behavior of this scalar."
|
||||
specifiedByLocations =
|
||||
[TypeSystemDirectiveLocation DirectiveLocation.Scalar]
|
||||
|
||||
-- | Traverses the schema and finds all referenced types.
|
||||
collectReferencedTypes :: forall m
|
||||
|
@ -200,7 +200,7 @@ typeSystemDefinition context rule = \case
|
||||
directives context rule schemaLocation directives'
|
||||
Full.TypeDefinition typeDefinition' ->
|
||||
typeDefinition context rule typeDefinition'
|
||||
Full.DirectiveDefinition _ _ arguments' _ ->
|
||||
Full.DirectiveDefinition _ _ arguments' _ _ ->
|
||||
argumentsDefinition context rule arguments'
|
||||
|
||||
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
|
||||
@ -482,4 +482,4 @@ directive context rule (Full.Directive directiveName arguments' _) =
|
||||
$ Validation.schema context
|
||||
in arguments rule argumentTypes arguments'
|
||||
where
|
||||
directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes
|
||||
directiveArguments (Schema.Directive _ argumentTypes _ _) = argumentTypes
|
||||
|
@ -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.
|
||||
@ -48,19 +50,21 @@ import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Foldable (find, fold, foldl', toList)
|
||||
import Data.Foldable (Foldable(..), find)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (groupBy, sortBy, sortOn)
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
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
|
||||
@ -250,14 +254,16 @@ findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
|
||||
-> Full.Location
|
||||
-> String
|
||||
-> RuleT m
|
||||
findDuplicates filterByName thisLocation errorMessage = do
|
||||
ast' <- asks ast
|
||||
let locations' = foldr filterByName [] ast'
|
||||
if length locations' > 1 && head locations' == thisLocation
|
||||
then pure $ error' locations'
|
||||
else lift mempty
|
||||
findDuplicates filterByName thisLocation errorMessage =
|
||||
asks ast >>= go . foldr filterByName []
|
||||
where
|
||||
error' locations' = Error
|
||||
go locations' =
|
||||
case locations' of
|
||||
headLocation : otherLocations -- length locations' > 1
|
||||
| not $ null otherLocations
|
||||
, headLocation == thisLocation -> pure $ makeError locations'
|
||||
_ -> lift mempty
|
||||
makeError locations' = Error
|
||||
{ message = errorMessage
|
||||
, locations = locations'
|
||||
}
|
||||
@ -533,11 +539,6 @@ uniqueDirectiveNamesRule = DirectivesRule
|
||||
extract (Full.Directive directiveName _ location') =
|
||||
(directiveName, location')
|
||||
|
||||
groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
|
||||
groupSorted getName = groupBy equalByName . sortOn getName
|
||||
where
|
||||
equalByName lhs rhs = getName lhs == getName rhs
|
||||
|
||||
filterDuplicates :: forall a
|
||||
. (a -> (Text, Full.Location))
|
||||
-> String
|
||||
@ -546,12 +547,12 @@ filterDuplicates :: forall a
|
||||
filterDuplicates extract nodeType = Seq.fromList
|
||||
. fmap makeError
|
||||
. filter ((> 1) . length)
|
||||
. groupSorted getName
|
||||
. NonEmpty.groupAllWith getName
|
||||
where
|
||||
getName = fst . extract
|
||||
makeError directives' = Error
|
||||
{ message = makeMessage $ head directives'
|
||||
, locations = snd . extract <$> directives'
|
||||
{ message = makeMessage $ NonEmpty.head directives'
|
||||
, locations = snd . extract <$> toList directives'
|
||||
}
|
||||
makeMessage directive = concat
|
||||
[ "There can be only one "
|
||||
@ -618,6 +619,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 +669,17 @@ 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 _ 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'
|
||||
@ -820,7 +831,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||
. Schema.directives . schema
|
||||
Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
|
||||
case available of
|
||||
Just (Schema.Directive _ _ definitions)
|
||||
Just (Schema.Directive _ definitions _ _)
|
||||
| not $ HashMap.member argumentName definitions ->
|
||||
pure $ makeError argumentName directiveName location'
|
||||
_ -> lift mempty
|
||||
@ -900,7 +911,7 @@ directivesInValidLocationsRule = DirectivesRule directivesRule
|
||||
maybeDefinition <- asks
|
||||
$ HashMap.lookup directiveName . Schema.directives . schema
|
||||
case maybeDefinition of
|
||||
Just (Schema.Directive _ allowedLocations _)
|
||||
Just (Schema.Directive _ _ _ allowedLocations)
|
||||
| directiveLocation `notElem` allowedLocations -> pure $ Error
|
||||
{ message = errorMessage directiveName directiveLocation
|
||||
, locations = [location]
|
||||
@ -930,7 +941,7 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
|
||||
available <- asks
|
||||
$ HashMap.lookup directiveName . Schema.directives . schema
|
||||
case available of
|
||||
Just (Schema.Directive _ _ definitions) ->
|
||||
Just (Schema.Directive _ definitions _ _) ->
|
||||
let forEach = go (directiveMessage directiveName) arguments location'
|
||||
in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
|
||||
_ -> lift mempty
|
||||
@ -1398,7 +1409,7 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
||||
let Full.Directive directiveName arguments _ = directive
|
||||
directiveDefinitions <- lift $ asks $ Schema.directives . schema
|
||||
case HashMap.lookup directiveName directiveDefinitions of
|
||||
Just (Schema.Directive _ _ directiveArguments) ->
|
||||
Just (Schema.Directive _ directiveArguments _ _) ->
|
||||
mapArguments variables directiveArguments arguments
|
||||
Nothing -> pure mempty
|
||||
mapArguments variables argumentTypes = fmap fold
|
||||
|
@ -7,6 +7,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
|
||||
import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..))
|
||||
import Test.QuickCheck.Gen (Gen (..))
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Functor ((<&>))
|
||||
|
||||
newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
|
||||
|
||||
@ -59,34 +60,36 @@ instance Arbitrary a => Arbitrary (AnyObjectField a) where
|
||||
location' <- getAnyLocation <$> arbitrary
|
||||
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
|
||||
|
||||
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show)
|
||||
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value }
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyValue where
|
||||
arbitrary = AnyValue <$> oneof
|
||||
[ variableGen
|
||||
, Doc.Int <$> arbitrary
|
||||
, Doc.Float <$> arbitrary
|
||||
, Doc.String <$> (getAnyPrintableText <$> arbitrary)
|
||||
, Doc.Boolean <$> arbitrary
|
||||
, MkGen $ \_ _ -> Doc.Null
|
||||
, Doc.Enum <$> (getAnyName <$> arbitrary)
|
||||
, Doc.List <$> listGen
|
||||
, Doc.Object <$> objectGen
|
||||
]
|
||||
where
|
||||
variableGen :: Gen Doc.Value
|
||||
variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
|
||||
listGen :: Gen [Doc.Node Doc.Value]
|
||||
listGen = (resize 5 . listOf) nodeGen
|
||||
nodeGen = do
|
||||
node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
|
||||
pure (getAnyValue <$> node')
|
||||
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
||||
objectGen = resize 1 $ do
|
||||
list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
|
||||
pure $ map (fmap getAnyValue . getAnyObjectField) list
|
||||
instance Arbitrary AnyValue
|
||||
where
|
||||
arbitrary =
|
||||
let variableGen :: Gen Doc.Value
|
||||
variableGen = Doc.Variable . getAnyName <$> arbitrary
|
||||
listGen :: Gen [Doc.Node Doc.Value]
|
||||
listGen = (resize 5 . listOf) nodeGen
|
||||
nodeGen :: Gen (Doc.Node Doc.Value)
|
||||
nodeGen = fmap getAnyNode arbitrary <&> fmap getAnyValue
|
||||
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
||||
objectGen = resize 1
|
||||
$ fmap getNonEmpty arbitrary
|
||||
<&> map (fmap getAnyValue . getAnyObjectField)
|
||||
in AnyValue <$> oneof
|
||||
[ variableGen
|
||||
, Doc.Int <$> arbitrary
|
||||
, Doc.Float <$> arbitrary
|
||||
, Doc.String . getAnyPrintableText <$> arbitrary
|
||||
, Doc.Boolean <$> arbitrary
|
||||
, MkGen $ \_ _ -> Doc.Null
|
||||
, Doc.Enum . getAnyName <$> arbitrary
|
||||
, Doc.List <$> listGen
|
||||
, Doc.Object <$> objectGen
|
||||
]
|
||||
|
||||
newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } deriving (Eq, Show)
|
||||
newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument }
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyArgument a) where
|
||||
arbitrary = do
|
||||
|
@ -11,6 +11,7 @@ import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
||||
import Test.QuickCheck (choose, oneof, forAll)
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
@ -267,3 +268,26 @@ spec = do
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
context "directive definition" $ do
|
||||
it "encodes a directive definition" $ do
|
||||
let definition' = Full.DirectiveDefinition mempty "example" mempty False
|
||||
$ pure
|
||||
$ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field
|
||||
expected = [gql|
|
||||
@example() on
|
||||
| FIELD
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "encodes a repeatable directive definition" $ do
|
||||
let definition' = Full.DirectiveDefinition mempty "example" mempty True
|
||||
$ pure
|
||||
$ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field
|
||||
expected = [gql|
|
||||
@example() repeatable on
|
||||
| FIELD
|
||||
|]
|
||||
actual = typeSystemDefinition pretty definition'
|
||||
in actual `shouldBe` expected
|
||||
|
@ -12,7 +12,12 @@ import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, describe, it, context)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
import Test.Hspec.Megaparsec
|
||||
( shouldParse
|
||||
, shouldFailOn
|
||||
, parseSatisfies
|
||||
, shouldSucceedOn
|
||||
)
|
||||
import Text.Megaparsec (parse)
|
||||
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
|
||||
import Language.GraphQL.AST.Arbitrary
|
||||
@ -70,7 +75,10 @@ spec = describe "Parser" $ do
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
|
||||
|
||||
it "fails to parse an empty argument list in parens" $
|
||||
parse document "" `shouldFailOn` "{ test() }"
|
||||
|
||||
it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
|
||||
let
|
||||
query' :: Text
|
||||
@ -143,22 +151,20 @@ spec = describe "Parser" $ do
|
||||
|]
|
||||
|
||||
it "parses two minimal directive definitions" $
|
||||
let directive nm loc =
|
||||
TypeSystemDefinition
|
||||
(DirectiveDefinition
|
||||
(Description Nothing)
|
||||
nm
|
||||
(ArgumentsDefinition [])
|
||||
(loc :| []))
|
||||
example1 =
|
||||
directive "example1"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
(Location {line = 1, column = 1})
|
||||
example2 =
|
||||
directive "example2"
|
||||
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
||||
(Location {line = 2, column = 1})
|
||||
testSchemaExtension = example1 :| [ example2 ]
|
||||
let directive name' loc = TypeSystemDefinition
|
||||
$ DirectiveDefinition
|
||||
(Description Nothing)
|
||||
name'
|
||||
(ArgumentsDefinition [])
|
||||
False
|
||||
(loc :| [])
|
||||
example1 = directive "example1"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
(Location {line = 1, column = 1})
|
||||
example2 = directive "example2"
|
||||
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
||||
(Location {line = 2, column = 1})
|
||||
testSchemaExtension = example1 :| [example2]
|
||||
query = [gql|
|
||||
directive @example1 on FIELD_DEFINITION
|
||||
directive @example2 on FIELD
|
||||
@ -166,31 +172,26 @@ spec = describe "Parser" $ do
|
||||
in parse document "" query `shouldParse` testSchemaExtension
|
||||
|
||||
it "parses a directive definition with a default empty list argument" $
|
||||
let directive nm loc args =
|
||||
TypeSystemDefinition
|
||||
(DirectiveDefinition
|
||||
(Description Nothing)
|
||||
nm
|
||||
(ArgumentsDefinition
|
||||
[ InputValueDefinition
|
||||
(Description Nothing)
|
||||
argName
|
||||
argType
|
||||
argValue
|
||||
[]
|
||||
| (argName, argType, argValue) <- args])
|
||||
(loc :| []))
|
||||
defn =
|
||||
directive "test"
|
||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||
[("foo",
|
||||
TypeList (TypeNamed "String"),
|
||||
Just
|
||||
$ Node (ConstList [])
|
||||
$ Location {line = 1, column = 33})]
|
||||
(Location {line = 1, column = 1})
|
||||
let argumentValue = Just
|
||||
$ Node (ConstList [])
|
||||
$ Location{ line = 1, column = 33 }
|
||||
loc = DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition
|
||||
argumentValueDefinition = InputValueDefinition
|
||||
(Description Nothing)
|
||||
"foo"
|
||||
(TypeList (TypeNamed "String"))
|
||||
argumentValue
|
||||
[]
|
||||
definition = DirectiveDefinition
|
||||
(Description Nothing)
|
||||
"test"
|
||||
(ArgumentsDefinition [argumentValueDefinition] )
|
||||
False
|
||||
(loc :| [])
|
||||
directive = TypeSystemDefinition definition
|
||||
$ Location{ line = 1, column = 1 }
|
||||
query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|]
|
||||
in parse document "" query `shouldParse` (defn :| [ ])
|
||||
in parse document "" query `shouldParse` (directive :| [])
|
||||
|
||||
it "parses schema extension with a new directive" $
|
||||
parse document "" `shouldSucceedOn`[gql|
|
||||
@ -210,6 +211,13 @@ spec = describe "Parser" $ do
|
||||
query = [gql|extend schema @newDirective { query: Query }|]
|
||||
in parse document "" query `shouldParse` (testSchemaExtension :| [])
|
||||
|
||||
it "parses a repeatable directive definition" $
|
||||
let given = [gql|directive @test repeatable on FIELD_DEFINITION|]
|
||||
isRepeatable (TypeSystemDefinition definition' _ :| [])
|
||||
| DirectiveDefinition _ _ _ repeatable _ <- definition' = repeatable
|
||||
isRepeatable _ = False
|
||||
in parse document "" given `parseSatisfies` isRepeatable
|
||||
|
||||
it "parses an object extension" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
extend type Story {
|
||||
|
@ -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"
|
||||
|
24
tests/Language/GraphQL/THSpec.hs
Normal file
24
tests/Language/GraphQL/THSpec.hs
Normal file
@ -0,0 +1,24 @@
|
||||
{- 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
|
@ -29,6 +29,7 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("dog", dogResolver)
|
||||
, ("cat", catResolver)
|
||||
, ("findDog", findDogResolver)
|
||||
, ("findCats", findCatsResolver)
|
||||
]
|
||||
where
|
||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||
@ -39,6 +40,11 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
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 @@ spec =
|
||||
}
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
context "noUndefinedVariablesRule" $
|
||||
context "noUndefinedVariablesRule" $ do
|
||||
it "rejects undefined variables" $
|
||||
let queryString = [gql|
|
||||
query variableIsNotDefinedUsedInSingleFragment {
|
||||
@ -560,7 +566,35 @@ spec =
|
||||
}
|
||||
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 @@ spec =
|
||||
}
|
||||
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 @@ 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 +969,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 +984,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]
|
||||
|
Loading…
Reference in New Issue
Block a user