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/).
|
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||||
|
|
||||||
## [Unreleased]
|
## [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
|
### 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.
|
||||||
|
- Fix used variables are not found in the properties of input objects.
|
||||||
|
|
||||||
## [1.2.0.1] - 2023-04-25
|
## [1.2.0.1] - 2023-04-25
|
||||||
### Fixed
|
### Fixed
|
||||||
@ -512,7 +535,10 @@ and this project adheres to
|
|||||||
### Added
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- 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.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.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.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
|
name: graphql
|
||||||
version: 1.2.0.1
|
version: 1.3.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||||
category: Language
|
category: Language
|
||||||
@ -11,7 +11,7 @@ author: Danny Navarro <j@dannynavarro.net>,
|
|||||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||||
maintainer: belka@caraus.de
|
maintainer: belka@caraus.de
|
||||||
copyright: (c) 2019-2023 Eugen Wissner,
|
copyright: (c) 2019-2024 Eugen Wissner,
|
||||||
(c) 2015-2017 J. Daniel Navarro
|
(c) 2015-2017 J. Daniel Navarro
|
||||||
license: MPL-2.0 AND BSD-3-Clause
|
license: MPL-2.0 AND BSD-3-Clause
|
||||||
license-files: LICENSE,
|
license-files: LICENSE,
|
||||||
@ -21,8 +21,7 @@ extra-source-files:
|
|||||||
CHANGELOG.md
|
CHANGELOG.md
|
||||||
README.md
|
README.md
|
||||||
tested-with:
|
tested-with:
|
||||||
GHC == 9.2.8,
|
GHC == 9.8.2
|
||||||
GHC == 9.6.2
|
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
@ -58,9 +57,9 @@ library
|
|||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.7 && < 5,
|
base >= 4.15 && < 5,
|
||||||
conduit ^>= 1.3.4,
|
conduit ^>= 1.3.4,
|
||||||
containers ^>= 0.6.2,
|
containers >= 0.6 && < 0.8,
|
||||||
exceptions ^>= 0.10.4,
|
exceptions ^>= 0.10.4,
|
||||||
megaparsec >= 9.0 && < 10,
|
megaparsec >= 9.0 && < 10,
|
||||||
parser-combinators >= 1.3 && < 2,
|
parser-combinators >= 1.3 && < 2,
|
||||||
@ -85,6 +84,7 @@ test-suite graphql-test
|
|||||||
Language.GraphQL.Execute.CoerceSpec
|
Language.GraphQL.Execute.CoerceSpec
|
||||||
Language.GraphQL.Execute.OrderedMapSpec
|
Language.GraphQL.Execute.OrderedMapSpec
|
||||||
Language.GraphQL.ExecuteSpec
|
Language.GraphQL.ExecuteSpec
|
||||||
|
Language.GraphQL.THSpec
|
||||||
Language.GraphQL.Type.OutSpec
|
Language.GraphQL.Type.OutSpec
|
||||||
Language.GraphQL.Validate.RulesSpec
|
Language.GraphQL.Validate.RulesSpec
|
||||||
Schemas.HeroSchema
|
Schemas.HeroSchema
|
||||||
@ -93,7 +93,7 @@ test-suite graphql-test
|
|||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
QuickCheck ^>= 2.14.1,
|
QuickCheck >= 2.14 && < 2.16,
|
||||||
base,
|
base,
|
||||||
conduit,
|
conduit,
|
||||||
exceptions,
|
exceptions,
|
||||||
@ -106,4 +106,6 @@ test-suite graphql-test
|
|||||||
unordered-containers,
|
unordered-containers,
|
||||||
containers,
|
containers,
|
||||||
vector
|
vector
|
||||||
|
build-tool-depends:
|
||||||
|
hspec-discover:hspec-discover
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -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
|
||||||
|
|
||||||
@ -405,7 +405,7 @@ data TypeSystemDefinition
|
|||||||
= SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
|
= SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
|
||||||
| TypeDefinition TypeDefinition
|
| TypeDefinition TypeDefinition
|
||||||
| DirectiveDefinition
|
| DirectiveDefinition
|
||||||
Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
|
Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation)
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Type System Extensions
|
-- ** Type System Extensions
|
||||||
|
@ -159,11 +159,12 @@ typeSystemDefinition formatter = \case
|
|||||||
<> optempty (directives formatter) operationDirectives
|
<> optempty (directives formatter) operationDirectives
|
||||||
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
<> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
|
||||||
Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
|
Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
|
||||||
Full.DirectiveDefinition description' name' arguments' locations
|
Full.DirectiveDefinition description' name' arguments' repeatable locations
|
||||||
-> description formatter description'
|
-> description formatter description'
|
||||||
<> "@"
|
<> "@"
|
||||||
<> Lazy.Text.fromStrict name'
|
<> Lazy.Text.fromStrict name'
|
||||||
<> argumentsDefinition formatter arguments'
|
<> argumentsDefinition formatter arguments'
|
||||||
|
<> (if repeatable then " repeatable" else mempty)
|
||||||
<> " on"
|
<> " on"
|
||||||
<> pipeList formatter (directiveLocation <$> locations)
|
<> pipeList formatter (directiveLocation <$> locations)
|
||||||
|
|
||||||
|
@ -29,7 +29,8 @@ module Language.GraphQL.AST.Lexer
|
|||||||
, unicodeBOM
|
, unicodeBOM
|
||||||
) where
|
) 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.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
|
||||||
import Data.Foldable (foldl')
|
import Data.Foldable (foldl')
|
||||||
import Data.List (dropWhileEnd)
|
import Data.List (dropWhileEnd)
|
||||||
@ -37,22 +38,22 @@ import qualified Data.List.NonEmpty as NonEmpty
|
|||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.Proxy (Proxy(..))
|
import Data.Proxy (Proxy(..))
|
||||||
import Data.Void (Void)
|
import Data.Void (Void)
|
||||||
import Text.Megaparsec ( Parsec
|
import Text.Megaparsec
|
||||||
, (<?>)
|
( Parsec
|
||||||
, between
|
, (<?>)
|
||||||
, chunk
|
, between
|
||||||
, chunkToTokens
|
, chunk
|
||||||
, notFollowedBy
|
, chunkToTokens
|
||||||
, oneOf
|
, notFollowedBy
|
||||||
, option
|
, oneOf
|
||||||
, optional
|
, option
|
||||||
, satisfy
|
, optional
|
||||||
, sepBy
|
, satisfy
|
||||||
, skipSome
|
, skipSome
|
||||||
, takeP
|
, takeP
|
||||||
, takeWhile1P
|
, takeWhile1P
|
||||||
, try
|
, try
|
||||||
)
|
)
|
||||||
import Text.Megaparsec.Char (char, digitChar, space1)
|
import Text.Megaparsec.Char (char, digitChar, space1)
|
||||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
@ -142,12 +143,13 @@ blockString :: Parser T.Text
|
|||||||
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
||||||
where
|
where
|
||||||
stringValue = do
|
stringValue = do
|
||||||
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
byLine <- NonEmpty.sepBy1 (many blockStringCharacter) lineTerminator
|
||||||
let indentSize = foldr countIndent 0 $ tail byLine
|
let indentSize = foldr countIndent 0 $ NonEmpty.tail byLine
|
||||||
withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
|
withoutIndent = NonEmpty.head byLine
|
||||||
|
: (removeIndent indentSize <$> NonEmpty.tail byLine)
|
||||||
withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
|
withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
|
||||||
|
|
||||||
return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
pure $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
|
||||||
removeEmptyLine [] = True
|
removeEmptyLine [] = True
|
||||||
removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
|
removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
|
||||||
removeEmptyLine _ = False
|
removeEmptyLine _ = False
|
||||||
@ -180,10 +182,10 @@ name :: Parser T.Text
|
|||||||
name = do
|
name = do
|
||||||
firstLetter <- nameFirstLetter
|
firstLetter <- nameFirstLetter
|
||||||
rest <- many $ nameFirstLetter <|> digitChar
|
rest <- many $ nameFirstLetter <|> digitChar
|
||||||
_ <- spaceConsumer
|
void spaceConsumer
|
||||||
return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
|
||||||
where
|
where
|
||||||
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
|
||||||
|
|
||||||
isChunkDelimiter :: Char -> Bool
|
isChunkDelimiter :: Char -> Bool
|
||||||
isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
|
isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
|
||||||
@ -197,25 +199,25 @@ lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
|
|||||||
isSourceCharacter :: Char -> Bool
|
isSourceCharacter :: Char -> Bool
|
||||||
isSourceCharacter = isSourceCharacter' . ord
|
isSourceCharacter = isSourceCharacter' . ord
|
||||||
where
|
where
|
||||||
isSourceCharacter' code = code >= 0x0020
|
isSourceCharacter' code
|
||||||
|| code == 0x0009
|
= code >= 0x0020
|
||||||
|| code == 0x000a
|
|| elem code [0x0009, 0x000a, 0x000d]
|
||||||
|| code == 0x000d
|
|
||||||
|
|
||||||
escapeSequence :: Parser Char
|
escapeSequence :: Parser Char
|
||||||
escapeSequence = do
|
escapeSequence = do
|
||||||
_ <- char '\\'
|
void $ char '\\'
|
||||||
escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
|
escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
|
||||||
case escaped of
|
case escaped of
|
||||||
'b' -> return '\b'
|
'b' -> pure '\b'
|
||||||
'f' -> return '\f'
|
'f' -> pure '\f'
|
||||||
'n' -> return '\n'
|
'n' -> pure '\n'
|
||||||
'r' -> return '\r'
|
'r' -> pure '\r'
|
||||||
't' -> return '\t'
|
't' -> pure '\t'
|
||||||
'u' -> chr . foldl' step 0
|
'u' -> chr
|
||||||
. chunkToTokens (Proxy :: Proxy T.Text)
|
. foldl' step 0
|
||||||
<$> takeP Nothing 4
|
. chunkToTokens (Proxy :: Proxy T.Text)
|
||||||
_ -> return escaped
|
<$> takeP Nothing 4
|
||||||
|
_ -> pure escaped
|
||||||
where
|
where
|
||||||
step accumulator = (accumulator * 16 +) . digitToInt
|
step accumulator = (accumulator * 16 +) . digitToInt
|
||||||
|
|
||||||
|
@ -8,7 +8,7 @@ module Language.GraphQL.AST.Parser
|
|||||||
( document
|
( document
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative (Alternative(..), liftA2, optional)
|
import Control.Applicative (Alternative(..), optional)
|
||||||
import Control.Applicative.Combinators (sepBy1)
|
import Control.Applicative.Combinators (sepBy1)
|
||||||
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
@ -27,6 +27,7 @@ import Text.Megaparsec
|
|||||||
, unPos
|
, unPos
|
||||||
, (<?>)
|
, (<?>)
|
||||||
)
|
)
|
||||||
|
import Data.Maybe (isJust)
|
||||||
|
|
||||||
-- | Parser for the GraphQL documents.
|
-- | Parser for the GraphQL documents.
|
||||||
document :: Parser Full.Document
|
document :: Parser Full.Document
|
||||||
@ -82,6 +83,7 @@ directiveDefinition description' = Full.DirectiveDefinition description'
|
|||||||
<* at
|
<* at
|
||||||
<*> name
|
<*> name
|
||||||
<*> argumentsDefinition
|
<*> argumentsDefinition
|
||||||
|
<*> (isJust <$> optional (symbol "repeatable"))
|
||||||
<* symbol "on"
|
<* symbol "on"
|
||||||
<*> directiveLocations
|
<*> directiveLocations
|
||||||
<?> "DirectiveDefinition"
|
<?> "DirectiveDefinition"
|
||||||
|
@ -8,28 +8,22 @@
|
|||||||
|
|
||||||
-- | Error handling.
|
-- | Error handling.
|
||||||
module Language.GraphQL.Error
|
module Language.GraphQL.Error
|
||||||
( CollectErrsT
|
( Error(..)
|
||||||
, Error(..)
|
|
||||||
, Path(..)
|
, Path(..)
|
||||||
, Resolution(..)
|
|
||||||
, ResolverException(..)
|
, ResolverException(..)
|
||||||
, Response(..)
|
, Response(..)
|
||||||
, ResponseEventStream
|
, ResponseEventStream
|
||||||
, parseError
|
, parseError
|
||||||
, runCollectErrs
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Conduit
|
import Conduit
|
||||||
import Control.Exception (Exception(..))
|
import Control.Exception (Exception(..))
|
||||||
import Control.Monad.Trans.State (StateT, runStateT)
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
|
||||||
import Data.Sequence (Seq(..), (|>))
|
import Data.Sequence (Seq(..), (|>))
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import Language.GraphQL.AST (Location(..), Name)
|
import Language.GraphQL.AST (Location(..))
|
||||||
import Language.GraphQL.Execute.Coerce
|
import Language.GraphQL.Execute.Coerce
|
||||||
import qualified Language.GraphQL.Type.Schema as Schema
|
|
||||||
import Prelude hiding (null)
|
import Prelude hiding (null)
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
( ParseErrorBundle(..)
|
( ParseErrorBundle(..)
|
||||||
@ -97,28 +91,3 @@ instance Show ResolverException where
|
|||||||
show (ResolverException e) = show e
|
show (ResolverException e) = show e
|
||||||
|
|
||||||
instance Exception ResolverException
|
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
|
$ Just inputValue
|
||||||
| otherwise -> throwM
|
| otherwise -> throwM
|
||||||
$ InputCoercionException (Text.unpack argumentName) variableType Nothing
|
$ InputCoercionException (Text.unpack argumentName) variableType Nothing
|
||||||
|
|
||||||
matchFieldValues' = matchFieldValues coerceArgumentValue
|
matchFieldValues' = matchFieldValues coerceArgumentValue
|
||||||
$ Full.node <$> argumentValues
|
$ Full.node <$> argumentValues
|
||||||
coerceArgumentValue inputType (Transform.Int integer) =
|
|
||||||
coerceInputLiteral inputType (Type.Int integer)
|
coerceArgumentValue inputType transform =
|
||||||
coerceArgumentValue inputType (Transform.Boolean boolean) =
|
coerceInputLiteral inputType $ extractArgumentValue transform
|
||||||
coerceInputLiteral inputType (Type.Boolean boolean)
|
|
||||||
coerceArgumentValue inputType (Transform.String string) =
|
extractArgumentValue (Transform.Int integer) = Type.Int integer
|
||||||
coerceInputLiteral inputType (Type.String string)
|
extractArgumentValue (Transform.Boolean boolean) = Type.Boolean boolean
|
||||||
coerceArgumentValue inputType (Transform.Float float) =
|
extractArgumentValue (Transform.String string) = Type.String string
|
||||||
coerceInputLiteral inputType (Type.Float float)
|
extractArgumentValue (Transform.Float float) = Type.Float float
|
||||||
coerceArgumentValue inputType (Transform.Enum enum) =
|
extractArgumentValue (Transform.Enum enum) = Type.Enum enum
|
||||||
coerceInputLiteral inputType (Type.Enum enum)
|
extractArgumentValue Transform.Null = Type.Null
|
||||||
coerceArgumentValue inputType Transform.Null
|
extractArgumentValue (Transform.List list) =
|
||||||
| In.isNonNullType inputType = Nothing
|
Type.List $ extractArgumentValue <$> list
|
||||||
| otherwise = coerceInputLiteral inputType Type.Null
|
extractArgumentValue (Transform.Object object) =
|
||||||
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
|
Type.Object $ extractArgumentValue <$> object
|
||||||
let coerceItem = coerceArgumentValue inputType
|
extractArgumentValue (Transform.Variable variable) = variable
|
||||||
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
|
|
||||||
|
|
||||||
collectFields :: Monad m
|
collectFields :: Monad m
|
||||||
=> Out.ObjectType m
|
=> Out.ObjectType m
|
||||||
|
@ -12,17 +12,26 @@ import Language.Haskell.TH (Exp(..), Lit(..))
|
|||||||
|
|
||||||
stripIndentation :: String -> String
|
stripIndentation :: String -> String
|
||||||
stripIndentation code = reverse
|
stripIndentation code = reverse
|
||||||
$ dropNewlines
|
$ dropWhile isLineBreak
|
||||||
$ reverse
|
$ reverse
|
||||||
$ unlines
|
$ unlines
|
||||||
$ indent spaces <$> lines withoutLeadingNewlines
|
$ indent spaces <$> lines' withoutLeadingNewlines
|
||||||
where
|
where
|
||||||
indent 0 xs = xs
|
indent 0 xs = xs
|
||||||
indent count (' ' : xs) = indent (count - 1) xs
|
indent count (' ' : xs) = indent (count - 1) xs
|
||||||
indent _ xs = xs
|
indent _ xs = xs
|
||||||
withoutLeadingNewlines = dropNewlines code
|
withoutLeadingNewlines = dropWhile isLineBreak code
|
||||||
dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==)
|
|
||||||
spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
|
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
|
-- | Removes leading and trailing newlines. Indentation of the first line is
|
||||||
-- removed from each line of the string.
|
-- removed from each line of the string.
|
||||||
|
@ -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, "]!"]
|
||||||
|
@ -66,13 +66,15 @@ 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)
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
-- | Field argument definitions.
|
-- | Field argument definitions.
|
||||||
type Arguments = HashMap Name Argument
|
type Arguments = HashMap Name Argument
|
||||||
|
@ -48,7 +48,11 @@ data Type m
|
|||||||
deriving Eq
|
deriving Eq
|
||||||
|
|
||||||
-- | Directive definition.
|
-- | 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.
|
-- | Directive definitions.
|
||||||
type Directives = HashMap Full.Name Directive
|
type Directives = HashMap Full.Name Directive
|
||||||
|
@ -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
|
||||||
|
@ -85,15 +85,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
|||||||
[ ("skip", skipDirective)
|
[ ("skip", skipDirective)
|
||||||
, ("include", includeDirective)
|
, ("include", includeDirective)
|
||||||
, ("deprecated", deprecatedDirective)
|
, ("deprecated", deprecatedDirective)
|
||||||
|
, ("specifiedBy", specifiedByDirective)
|
||||||
]
|
]
|
||||||
includeDirective =
|
includeDirective =
|
||||||
Directive includeDescription skipIncludeLocations includeArguments
|
Directive includeDescription includeArguments False skipIncludeLocations
|
||||||
includeArguments = HashMap.singleton "if"
|
includeArguments = HashMap.singleton "if"
|
||||||
$ In.Argument (Just "Included when true.") ifType Nothing
|
$ In.Argument (Just "Included when true.") ifType Nothing
|
||||||
includeDescription = Just
|
includeDescription = Just
|
||||||
"Directs the executor to include this field or fragment only when the \
|
"Directs the executor to include this field or fragment only when the \
|
||||||
\`if` argument is true."
|
\`if` argument is true."
|
||||||
skipDirective = Directive skipDescription skipIncludeLocations skipArguments
|
skipDirective = Directive skipDescription skipArguments False skipIncludeLocations
|
||||||
skipArguments = HashMap.singleton "if"
|
skipArguments = HashMap.singleton "if"
|
||||||
$ In.Argument (Just "skipped when true.") ifType Nothing
|
$ In.Argument (Just "skipped when true.") ifType Nothing
|
||||||
ifType = In.NonNullScalarType Definition.boolean
|
ifType = In.NonNullScalarType Definition.boolean
|
||||||
@ -106,16 +107,15 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
|||||||
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
||||||
]
|
]
|
||||||
deprecatedDirective =
|
deprecatedDirective =
|
||||||
Directive deprecatedDescription deprecatedLocations deprecatedArguments
|
Directive deprecatedDescription deprecatedArguments False deprecatedLocations
|
||||||
reasonDescription = Just
|
reasonDescription = Just
|
||||||
"Explains why this element was deprecated, usually also including a \
|
"Explains why this element was deprecated, usually also including a \
|
||||||
\suggestion for how to access supported similar data. Formatted using \
|
\suggestion for how to access supported similar data. Formatted using \
|
||||||
\the Markdown syntax, as specified by \
|
\the Markdown syntax, as specified by \
|
||||||
\[CommonMark](https://commonmark.org/).'"
|
\[CommonMark](https://commonmark.org/).'"
|
||||||
deprecatedArguments = HashMap.singleton "reason"
|
deprecatedArguments = HashMap.singleton "reason"
|
||||||
$ In.Argument reasonDescription reasonType
|
$ In.Argument reasonDescription (In.NamedScalarType Definition.string)
|
||||||
$ Just "No longer supported"
|
$ Just "No longer supported"
|
||||||
reasonType = In.NamedScalarType Definition.string
|
|
||||||
deprecatedDescription = Just
|
deprecatedDescription = Just
|
||||||
"Marks an element of a GraphQL schema as no longer supported."
|
"Marks an element of a GraphQL schema as no longer supported."
|
||||||
deprecatedLocations =
|
deprecatedLocations =
|
||||||
@ -124,6 +124,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
|
|||||||
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
||||||
, TypeSystemDirectiveLocation DirectiveLocation.EnumValue
|
, 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.
|
-- | Traverses the schema and finds all referenced types.
|
||||||
collectReferencedTypes :: forall m
|
collectReferencedTypes :: forall m
|
||||||
|
@ -200,7 +200,7 @@ typeSystemDefinition context rule = \case
|
|||||||
directives context rule schemaLocation directives'
|
directives context rule schemaLocation directives'
|
||||||
Full.TypeDefinition typeDefinition' ->
|
Full.TypeDefinition typeDefinition' ->
|
||||||
typeDefinition context rule typeDefinition'
|
typeDefinition context rule typeDefinition'
|
||||||
Full.DirectiveDefinition _ _ arguments' _ ->
|
Full.DirectiveDefinition _ _ arguments' _ _ ->
|
||||||
argumentsDefinition context rule arguments'
|
argumentsDefinition context rule arguments'
|
||||||
|
|
||||||
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
|
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
|
||||||
@ -482,4 +482,4 @@ directive context rule (Full.Directive directiveName arguments' _) =
|
|||||||
$ Validation.schema context
|
$ Validation.schema context
|
||||||
in arguments rule argumentTypes arguments'
|
in arguments rule argumentTypes arguments'
|
||||||
where
|
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
|
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/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
-- | This module contains default rules defined in the GraphQL specification.
|
-- | 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.Reader (ReaderT(..), ask, asks, mapReaderT)
|
||||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
import Data.Foldable (find, fold, foldl', toList)
|
import Data.Foldable (Foldable(..), find)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import qualified Data.HashSet as 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.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import Data.Ord (comparing)
|
import Data.Ord (comparing)
|
||||||
import Data.Sequence (Seq(..), (|>))
|
import Data.Sequence (Seq(..), (|>))
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
import GHC.Records (HasField(..))
|
||||||
import qualified Language.GraphQL.AST.Document as Full
|
import qualified Language.GraphQL.AST.Document as Full
|
||||||
import qualified Language.GraphQL.Type.Definition as Definition
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
import qualified Language.GraphQL.Type.Internal as Type
|
import qualified Language.GraphQL.Type.Internal as Type
|
||||||
@ -250,14 +254,16 @@ findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
|
|||||||
-> Full.Location
|
-> Full.Location
|
||||||
-> String
|
-> String
|
||||||
-> RuleT m
|
-> RuleT m
|
||||||
findDuplicates filterByName thisLocation errorMessage = do
|
findDuplicates filterByName thisLocation errorMessage =
|
||||||
ast' <- asks ast
|
asks ast >>= go . foldr filterByName []
|
||||||
let locations' = foldr filterByName [] ast'
|
|
||||||
if length locations' > 1 && head locations' == thisLocation
|
|
||||||
then pure $ error' locations'
|
|
||||||
else lift mempty
|
|
||||||
where
|
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
|
{ message = errorMessage
|
||||||
, locations = locations'
|
, locations = locations'
|
||||||
}
|
}
|
||||||
@ -533,11 +539,6 @@ uniqueDirectiveNamesRule = DirectivesRule
|
|||||||
extract (Full.Directive directiveName _ location') =
|
extract (Full.Directive directiveName _ location') =
|
||||||
(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
|
filterDuplicates :: forall a
|
||||||
. (a -> (Text, Full.Location))
|
. (a -> (Text, Full.Location))
|
||||||
-> String
|
-> String
|
||||||
@ -546,12 +547,12 @@ filterDuplicates :: forall a
|
|||||||
filterDuplicates extract nodeType = Seq.fromList
|
filterDuplicates extract nodeType = Seq.fromList
|
||||||
. fmap makeError
|
. fmap makeError
|
||||||
. filter ((> 1) . length)
|
. filter ((> 1) . length)
|
||||||
. groupSorted getName
|
. NonEmpty.groupAllWith getName
|
||||||
where
|
where
|
||||||
getName = fst . extract
|
getName = fst . extract
|
||||||
makeError directives' = Error
|
makeError directives' = Error
|
||||||
{ message = makeMessage $ head directives'
|
{ message = makeMessage $ NonEmpty.head directives'
|
||||||
, locations = snd . extract <$> directives'
|
, locations = snd . extract <$> toList directives'
|
||||||
}
|
}
|
||||||
makeMessage directive = concat
|
makeMessage directive = concat
|
||||||
[ "There can be only one "
|
[ "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
|
type UsageDifference
|
||||||
= HashMap Full.Name [Full.Location]
|
= HashMap Full.Name [Full.Location]
|
||||||
-> HashMap Full.Name [Full.Location]
|
-> HashMap Full.Name [Full.Location]
|
||||||
@ -664,11 +669,17 @@ 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 _ value _) = findNodeVariables value
|
||||||
findArgumentVariables _ = Nothing
|
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
|
makeError operationName (variableName, locations') = Error
|
||||||
{ message = errorMessage operationName variableName
|
{ message = errorMessage operationName variableName
|
||||||
, locations = locations'
|
, locations = locations'
|
||||||
@ -820,7 +831,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
|||||||
. Schema.directives . schema
|
. Schema.directives . schema
|
||||||
Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
|
Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
|
||||||
case available of
|
case available of
|
||||||
Just (Schema.Directive _ _ definitions)
|
Just (Schema.Directive _ definitions _ _)
|
||||||
| not $ HashMap.member argumentName definitions ->
|
| not $ HashMap.member argumentName definitions ->
|
||||||
pure $ makeError argumentName directiveName location'
|
pure $ makeError argumentName directiveName location'
|
||||||
_ -> lift mempty
|
_ -> lift mempty
|
||||||
@ -900,7 +911,7 @@ directivesInValidLocationsRule = DirectivesRule directivesRule
|
|||||||
maybeDefinition <- asks
|
maybeDefinition <- asks
|
||||||
$ HashMap.lookup directiveName . Schema.directives . schema
|
$ HashMap.lookup directiveName . Schema.directives . schema
|
||||||
case maybeDefinition of
|
case maybeDefinition of
|
||||||
Just (Schema.Directive _ allowedLocations _)
|
Just (Schema.Directive _ _ _ allowedLocations)
|
||||||
| directiveLocation `notElem` allowedLocations -> pure $ Error
|
| directiveLocation `notElem` allowedLocations -> pure $ Error
|
||||||
{ message = errorMessage directiveName directiveLocation
|
{ message = errorMessage directiveName directiveLocation
|
||||||
, locations = [location]
|
, locations = [location]
|
||||||
@ -930,7 +941,7 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
|
|||||||
available <- asks
|
available <- asks
|
||||||
$ HashMap.lookup directiveName . Schema.directives . schema
|
$ HashMap.lookup directiveName . Schema.directives . schema
|
||||||
case available of
|
case available of
|
||||||
Just (Schema.Directive _ _ definitions) ->
|
Just (Schema.Directive _ definitions _ _) ->
|
||||||
let forEach = go (directiveMessage directiveName) arguments location'
|
let forEach = go (directiveMessage directiveName) arguments location'
|
||||||
in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
|
in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
|
||||||
_ -> lift mempty
|
_ -> lift mempty
|
||||||
@ -1398,7 +1409,7 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
|
|||||||
let Full.Directive directiveName arguments _ = directive
|
let Full.Directive directiveName arguments _ = directive
|
||||||
directiveDefinitions <- lift $ asks $ Schema.directives . schema
|
directiveDefinitions <- lift $ asks $ Schema.directives . schema
|
||||||
case HashMap.lookup directiveName directiveDefinitions of
|
case HashMap.lookup directiveName directiveDefinitions of
|
||||||
Just (Schema.Directive _ _ directiveArguments) ->
|
Just (Schema.Directive _ directiveArguments _ _) ->
|
||||||
mapArguments variables directiveArguments arguments
|
mapArguments variables directiveArguments arguments
|
||||||
Nothing -> pure mempty
|
Nothing -> pure mempty
|
||||||
mapArguments variables argumentTypes = fmap fold
|
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 (oneof, elements, listOf, resize, NonEmptyList (..))
|
||||||
import Test.QuickCheck.Gen (Gen (..))
|
import Test.QuickCheck.Gen (Gen (..))
|
||||||
import Data.Text (Text, pack)
|
import Data.Text (Text, pack)
|
||||||
|
import Data.Functor ((<&>))
|
||||||
|
|
||||||
newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
|
newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
|
||||||
|
|
||||||
@ -59,34 +60,36 @@ instance Arbitrary a => Arbitrary (AnyObjectField a) where
|
|||||||
location' <- getAnyLocation <$> arbitrary
|
location' <- getAnyLocation <$> arbitrary
|
||||||
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
|
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
|
instance Arbitrary AnyValue
|
||||||
arbitrary = AnyValue <$> oneof
|
where
|
||||||
[ variableGen
|
arbitrary =
|
||||||
, Doc.Int <$> arbitrary
|
let variableGen :: Gen Doc.Value
|
||||||
, Doc.Float <$> arbitrary
|
variableGen = Doc.Variable . getAnyName <$> arbitrary
|
||||||
, Doc.String <$> (getAnyPrintableText <$> arbitrary)
|
listGen :: Gen [Doc.Node Doc.Value]
|
||||||
, Doc.Boolean <$> arbitrary
|
listGen = (resize 5 . listOf) nodeGen
|
||||||
, MkGen $ \_ _ -> Doc.Null
|
nodeGen :: Gen (Doc.Node Doc.Value)
|
||||||
, Doc.Enum <$> (getAnyName <$> arbitrary)
|
nodeGen = fmap getAnyNode arbitrary <&> fmap getAnyValue
|
||||||
, Doc.List <$> listGen
|
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
||||||
, Doc.Object <$> objectGen
|
objectGen = resize 1
|
||||||
]
|
$ fmap getNonEmpty arbitrary
|
||||||
where
|
<&> map (fmap getAnyValue . getAnyObjectField)
|
||||||
variableGen :: Gen Doc.Value
|
in AnyValue <$> oneof
|
||||||
variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
|
[ variableGen
|
||||||
listGen :: Gen [Doc.Node Doc.Value]
|
, Doc.Int <$> arbitrary
|
||||||
listGen = (resize 5 . listOf) nodeGen
|
, Doc.Float <$> arbitrary
|
||||||
nodeGen = do
|
, Doc.String . getAnyPrintableText <$> arbitrary
|
||||||
node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
|
, Doc.Boolean <$> arbitrary
|
||||||
pure (getAnyValue <$> node')
|
, MkGen $ \_ _ -> Doc.Null
|
||||||
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
, Doc.Enum . getAnyName <$> arbitrary
|
||||||
objectGen = resize 1 $ do
|
, Doc.List <$> listGen
|
||||||
list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
|
, Doc.Object <$> objectGen
|
||||||
pure $ map (fmap getAnyValue . getAnyObjectField) list
|
]
|
||||||
|
|
||||||
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
|
instance Arbitrary a => Arbitrary (AnyArgument a) where
|
||||||
arbitrary = do
|
arbitrary = do
|
||||||
|
@ -11,6 +11,7 @@ import Language.GraphQL.TH
|
|||||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
||||||
import Test.QuickCheck (choose, oneof, forAll)
|
import Test.QuickCheck (choose, oneof, forAll)
|
||||||
import qualified Data.Text.Lazy as Text.Lazy
|
import qualified Data.Text.Lazy as Text.Lazy
|
||||||
|
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
@ -267,3 +268,26 @@ spec = do
|
|||||||
|]
|
|]
|
||||||
actual = typeSystemDefinition pretty definition'
|
actual = typeSystemDefinition pretty definition'
|
||||||
in actual `shouldBe` expected
|
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.AST.Parser
|
||||||
import Language.GraphQL.TH
|
import Language.GraphQL.TH
|
||||||
import Test.Hspec (Spec, describe, it, context)
|
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 Text.Megaparsec (parse)
|
||||||
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
|
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
|
||||||
import Language.GraphQL.AST.Arbitrary
|
import Language.GraphQL.AST.Arbitrary
|
||||||
@ -71,6 +76,9 @@ spec = describe "Parser" $ do
|
|||||||
test(username: """username""", password: """password""")
|
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 ->
|
it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
|
||||||
let
|
let
|
||||||
query' :: Text
|
query' :: Text
|
||||||
@ -143,22 +151,20 @@ spec = describe "Parser" $ do
|
|||||||
|]
|
|]
|
||||||
|
|
||||||
it "parses two minimal directive definitions" $
|
it "parses two minimal directive definitions" $
|
||||||
let directive nm loc =
|
let directive name' loc = TypeSystemDefinition
|
||||||
TypeSystemDefinition
|
$ DirectiveDefinition
|
||||||
(DirectiveDefinition
|
(Description Nothing)
|
||||||
(Description Nothing)
|
name'
|
||||||
nm
|
(ArgumentsDefinition [])
|
||||||
(ArgumentsDefinition [])
|
False
|
||||||
(loc :| []))
|
(loc :| [])
|
||||||
example1 =
|
example1 = directive "example1"
|
||||||
directive "example1"
|
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
||||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
(Location {line = 1, column = 1})
|
||||||
(Location {line = 1, column = 1})
|
example2 = directive "example2"
|
||||||
example2 =
|
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
||||||
directive "example2"
|
(Location {line = 2, column = 1})
|
||||||
(DirLoc.ExecutableDirectiveLocation DirLoc.Field)
|
testSchemaExtension = example1 :| [example2]
|
||||||
(Location {line = 2, column = 1})
|
|
||||||
testSchemaExtension = example1 :| [ example2 ]
|
|
||||||
query = [gql|
|
query = [gql|
|
||||||
directive @example1 on FIELD_DEFINITION
|
directive @example1 on FIELD_DEFINITION
|
||||||
directive @example2 on FIELD
|
directive @example2 on FIELD
|
||||||
@ -166,31 +172,26 @@ spec = describe "Parser" $ do
|
|||||||
in parse document "" query `shouldParse` testSchemaExtension
|
in parse document "" query `shouldParse` testSchemaExtension
|
||||||
|
|
||||||
it "parses a directive definition with a default empty list argument" $
|
it "parses a directive definition with a default empty list argument" $
|
||||||
let directive nm loc args =
|
let argumentValue = Just
|
||||||
TypeSystemDefinition
|
$ Node (ConstList [])
|
||||||
(DirectiveDefinition
|
$ Location{ line = 1, column = 33 }
|
||||||
(Description Nothing)
|
loc = DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition
|
||||||
nm
|
argumentValueDefinition = InputValueDefinition
|
||||||
(ArgumentsDefinition
|
(Description Nothing)
|
||||||
[ InputValueDefinition
|
"foo"
|
||||||
(Description Nothing)
|
(TypeList (TypeNamed "String"))
|
||||||
argName
|
argumentValue
|
||||||
argType
|
[]
|
||||||
argValue
|
definition = DirectiveDefinition
|
||||||
[]
|
(Description Nothing)
|
||||||
| (argName, argType, argValue) <- args])
|
"test"
|
||||||
(loc :| []))
|
(ArgumentsDefinition [argumentValueDefinition] )
|
||||||
defn =
|
False
|
||||||
directive "test"
|
(loc :| [])
|
||||||
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
|
directive = TypeSystemDefinition definition
|
||||||
[("foo",
|
$ Location{ line = 1, column = 1 }
|
||||||
TypeList (TypeNamed "String"),
|
|
||||||
Just
|
|
||||||
$ Node (ConstList [])
|
|
||||||
$ Location {line = 1, column = 33})]
|
|
||||||
(Location {line = 1, column = 1})
|
|
||||||
query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|]
|
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" $
|
it "parses schema extension with a new directive" $
|
||||||
parse document "" `shouldSucceedOn`[gql|
|
parse document "" `shouldSucceedOn`[gql|
|
||||||
@ -210,6 +211,13 @@ spec = describe "Parser" $ do
|
|||||||
query = [gql|extend schema @newDirective { query: Query }|]
|
query = [gql|extend schema @newDirective { query: Query }|]
|
||||||
in parse document "" query `shouldParse` (testSchemaExtension :| [])
|
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" $
|
it "parses an object extension" $
|
||||||
parse document "" `shouldSucceedOn` [gql|
|
parse document "" `shouldSucceedOn` [gql|
|
||||||
extend type Story {
|
extend type Story {
|
||||||
|
@ -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"
|
||||||
|
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)
|
[ ("dog", dogResolver)
|
||||||
, ("cat", catResolver)
|
, ("cat", catResolver)
|
||||||
, ("findDog", findDogResolver)
|
, ("findDog", findDogResolver)
|
||||||
|
, ("findCats", findCatsResolver)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||||
@ -39,6 +40,11 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
|||||||
findDogResolver = ValueResolver findDogField $ pure Null
|
findDogResolver = ValueResolver findDogField $ pure Null
|
||||||
catField = Field Nothing (Out.NamedObjectType catType) mempty
|
catField = Field Nothing (Out.NamedObjectType catType) mempty
|
||||||
catResolver = ValueResolver catField $ pure Null
|
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
|
||||||
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
|
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
|
||||||
@ -538,7 +544,7 @@ spec =
|
|||||||
}
|
}
|
||||||
in validate queryString `shouldContain` [expected]
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
context "noUndefinedVariablesRule" $
|
context "noUndefinedVariablesRule" $ do
|
||||||
it "rejects undefined variables" $
|
it "rejects undefined variables" $
|
||||||
let queryString = [gql|
|
let queryString = [gql|
|
||||||
query variableIsNotDefinedUsedInSingleFragment {
|
query variableIsNotDefinedUsedInSingleFragment {
|
||||||
@ -560,7 +566,35 @@ spec =
|
|||||||
}
|
}
|
||||||
in validate queryString `shouldBe` [expected]
|
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" $
|
it "rejects unused variables" $
|
||||||
let queryString = [gql|
|
let queryString = [gql|
|
||||||
query variableUnused($atOtherHomes: Boolean) {
|
query variableUnused($atOtherHomes: Boolean) {
|
||||||
@ -577,6 +611,16 @@ spec =
|
|||||||
}
|
}
|
||||||
in validate queryString `shouldBe` [expected]
|
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" $
|
context "uniqueInputFieldNamesRule" $
|
||||||
it "rejects duplicate fields in input objects" $
|
it "rejects duplicate fields in input objects" $
|
||||||
let queryString = [gql|
|
let queryString = [gql|
|
||||||
@ -878,7 +922,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 +969,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 +984,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]
|
||||||
|
Loading…
Reference in New Issue
Block a user