Compare commits
8 Commits
Author | SHA1 | Date | |
---|---|---|---|
497edf326d | |||
663e4f3521 | |||
324a4c55ff | |||
7ea76865e6 | |||
2dcefff76a | |||
27a5a0b44e | |||
97627ffc36 | |||
6f7bb10a62 |
@ -21,8 +21,8 @@ jobs:
|
|||||||
- name: Install dependencies
|
- name: Install dependencies
|
||||||
run: cabal update
|
run: cabal update
|
||||||
- name: Prepare system
|
- name: Prepare system
|
||||||
run: cabal build graphql-test
|
run: cabal build graphql-test --enable-tests
|
||||||
- run: cabal test --test-show-details=streaming
|
- run: cabal test --test-show-details=streaming --enable-tests
|
||||||
|
|
||||||
doc:
|
doc:
|
||||||
runs-on: buildenv
|
runs-on: buildenv
|
||||||
|
@ -6,6 +6,14 @@ The format is based on
|
|||||||
and this project adheres to
|
and this project adheres to
|
||||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||||
|
|
||||||
|
## [1.5.0.0] - 2024-12-03
|
||||||
|
### Removed
|
||||||
|
- Remove deprecated 'gql' quasi quoter.
|
||||||
|
|
||||||
|
### Changed
|
||||||
|
- Validate the subscription root not to be an introspection field
|
||||||
|
(`singleFieldSubscriptionsRule`).
|
||||||
|
|
||||||
## [1.4.0.0] - 2024-10-26
|
## [1.4.0.0] - 2024-10-26
|
||||||
### Changed
|
### Changed
|
||||||
- `Schema.Directive` is extended to contain a boolean argument, representing
|
- `Schema.Directive` is extended to contain a boolean argument, representing
|
||||||
@ -538,6 +546,7 @@ and this project adheres to
|
|||||||
### Added
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- Data types for the GraphQL language.
|
||||||
|
|
||||||
|
[1.5.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.4.0.0...v1.5.0.0
|
||||||
[1.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.3.0.0...v1.4.0.0
|
[1.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.3.0.0...v1.4.0.0
|
||||||
[1.3.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.3...v1.3.0.0
|
[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.3]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.2...v1.2.0.3
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
cabal-version: 3.0
|
cabal-version: 3.0
|
||||||
|
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 1.4.0.0
|
version: 1.5.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-2024 Eugen Wissner,
|
copyright: (c) 2019-2025 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,7 +21,7 @@ extra-source-files:
|
|||||||
CHANGELOG.md
|
CHANGELOG.md
|
||||||
README.md
|
README.md
|
||||||
tested-with:
|
tested-with:
|
||||||
GHC == 9.8.2
|
GHC == 9.10.1
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
@ -40,7 +40,6 @@ library
|
|||||||
Language.GraphQL.Execute
|
Language.GraphQL.Execute
|
||||||
Language.GraphQL.Execute.Coerce
|
Language.GraphQL.Execute.Coerce
|
||||||
Language.GraphQL.Execute.OrderedMap
|
Language.GraphQL.Execute.OrderedMap
|
||||||
Language.GraphQL.TH
|
|
||||||
Language.GraphQL.Type
|
Language.GraphQL.Type
|
||||||
Language.GraphQL.Type.In
|
Language.GraphQL.Type.In
|
||||||
Language.GraphQL.Type.Out
|
Language.GraphQL.Type.Out
|
||||||
@ -63,7 +62,6 @@ library
|
|||||||
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,
|
||||||
template-haskell >= 2.16 && < 3,
|
|
||||||
text >= 1.2 && < 3,
|
text >= 1.2 && < 3,
|
||||||
transformers >= 0.5.6 && < 0.7,
|
transformers >= 0.5.6 && < 0.7,
|
||||||
unordered-containers ^>= 0.2.14,
|
unordered-containers ^>= 0.2.14,
|
||||||
@ -84,7 +82,6 @@ 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
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | Target AST for parser.
|
-- | Target AST for parser.
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | Various parts of a GraphQL document can be annotated with directives.
|
-- | Various parts of a GraphQL document can be annotated with directives.
|
||||||
|
@ -3,6 +3,7 @@
|
|||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
||||||
@ -482,12 +483,9 @@ instance Monoid Description
|
|||||||
data TypeDefinition
|
data TypeDefinition
|
||||||
= ScalarTypeDefinition Description Name [Directive]
|
= ScalarTypeDefinition Description Name [Directive]
|
||||||
| ObjectTypeDefinition
|
| ObjectTypeDefinition
|
||||||
Description
|
Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
|
||||||
Name
|
| InterfaceTypeDefinition
|
||||||
(ImplementsInterfaces [])
|
Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
|
||||||
[Directive]
|
|
||||||
[FieldDefinition]
|
|
||||||
| InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
|
|
||||||
| UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
|
| UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
|
||||||
| EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
|
| EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
|
||||||
| InputObjectTypeDefinition
|
| InputObjectTypeDefinition
|
||||||
|
@ -2,6 +2,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | This module defines a minifier and a printer for the @GraphQL@ language.
|
-- | This module defines a minifier and a printer for the @GraphQL@ language.
|
||||||
@ -226,10 +227,11 @@ typeDefinition formatter = \case
|
|||||||
<> optempty (directives formatter) directives'
|
<> optempty (directives formatter) directives'
|
||||||
<> eitherFormat formatter " " ""
|
<> eitherFormat formatter " " ""
|
||||||
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
||||||
Full.InterfaceTypeDefinition description' name' directives' fields'
|
Full.InterfaceTypeDefinition description' name' ifaces' directives' fields'
|
||||||
-> optempty (description formatter) description'
|
-> optempty (description formatter) description'
|
||||||
<> "interface "
|
<> "interface "
|
||||||
<> Lazy.Text.fromStrict name'
|
<> Lazy.Text.fromStrict name'
|
||||||
|
<> optempty (" " <>) (implementsInterfaces ifaces')
|
||||||
<> optempty (directives formatter) directives'
|
<> optempty (directives formatter) directives'
|
||||||
<> eitherFormat formatter " " ""
|
<> eitherFormat formatter " " ""
|
||||||
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
<> bracesList formatter (fieldDefinition nextFormatter) fields'
|
||||||
|
@ -1,5 +1,7 @@
|
|||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | This module defines a bunch of small parsers used to parse individual
|
-- | This module defines a bunch of small parsers used to parse individual
|
||||||
-- lexemes.
|
-- lexemes.
|
||||||
|
@ -2,6 +2,8 @@
|
|||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | @GraphQL@ document parser.
|
-- | @GraphQL@ document parser.
|
||||||
module Language.GraphQL.AST.Parser
|
module Language.GraphQL.AST.Parser
|
||||||
@ -214,6 +216,7 @@ interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|||||||
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
|
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
|
||||||
<$ symbol "interface"
|
<$ symbol "interface"
|
||||||
<*> name
|
<*> name
|
||||||
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||||
<*> directives
|
<*> directives
|
||||||
<*> braces (many fieldDefinition)
|
<*> braces (many fieldDefinition)
|
||||||
<?> "InterfaceTypeDefinition"
|
<?> "InterfaceTypeDefinition"
|
||||||
|
@ -189,6 +189,8 @@ data QueryError
|
|||||||
| CoercionError Full.VariableDefinition
|
| CoercionError Full.VariableDefinition
|
||||||
| UnknownInputType Full.VariableDefinition
|
| UnknownInputType Full.VariableDefinition
|
||||||
|
|
||||||
|
type ExecuteHandler m a e = e -> ExecutorT m a
|
||||||
|
|
||||||
tell :: Monad m => Seq Error -> ExecutorT m ()
|
tell :: Monad m => Seq Error -> ExecutorT m ()
|
||||||
tell = ExecutorT . lift . Writer.tell
|
tell = ExecutorT . lift . Writer.tell
|
||||||
|
|
||||||
@ -313,8 +315,7 @@ executeQuery topSelections schema = do
|
|||||||
pure $ Response data' errors
|
pure $ Response data' errors
|
||||||
|
|
||||||
handleException :: (MonadCatch m, Serialize a)
|
handleException :: (MonadCatch m, Serialize a)
|
||||||
=> FieldException
|
=> ExecuteHandler m a FieldException
|
||||||
-> ExecutorT m a
|
|
||||||
handleException (FieldException fieldLocation errorPath next) =
|
handleException (FieldException fieldLocation errorPath next) =
|
||||||
let newError = constructError next fieldLocation errorPath
|
let newError = constructError next fieldLocation errorPath
|
||||||
in tell (Seq.singleton newError) >> pure null
|
in tell (Seq.singleton newError) >> pure null
|
||||||
@ -390,30 +391,28 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
|
|||||||
fieldErrorPath = fieldsSegment fields : errorPath
|
fieldErrorPath = fieldsSegment fields : errorPath
|
||||||
inputCoercionHandler :: (MonadCatch m, Serialize a)
|
inputCoercionHandler :: (MonadCatch m, Serialize a)
|
||||||
=> Full.Location
|
=> Full.Location
|
||||||
-> InputCoercionException
|
-> ExecuteHandler m a InputCoercionException
|
||||||
-> ExecutorT m a
|
|
||||||
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
|
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
|
||||||
let argumentLocation = getField @"location" valueNode
|
let argumentLocation = getField @"location" valueNode
|
||||||
in exceptionHandler argumentLocation e
|
in exceptionHandler argumentLocation e
|
||||||
inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
|
inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
|
||||||
resultHandler :: (MonadCatch m, Serialize a)
|
resultHandler :: (MonadCatch m, Serialize a)
|
||||||
=> Full.Location
|
=> Full.Location
|
||||||
-> ResultException
|
-> ExecuteHandler m a ResultException
|
||||||
-> ExecutorT m a
|
|
||||||
resultHandler = exceptionHandler
|
resultHandler = exceptionHandler
|
||||||
resolverHandler :: (MonadCatch m, Serialize a)
|
resolverHandler :: (MonadCatch m, Serialize a)
|
||||||
=> Full.Location
|
=> Full.Location
|
||||||
-> ResolverException
|
-> ExecuteHandler m a ResolverException
|
||||||
-> ExecutorT m a
|
|
||||||
resolverHandler = exceptionHandler
|
resolverHandler = exceptionHandler
|
||||||
nullResultHandler :: (MonadCatch m, Serialize a)
|
nullResultHandler :: (MonadCatch m, Serialize a) => ExecuteHandler m a FieldException
|
||||||
=> FieldException
|
|
||||||
-> ExecutorT m a
|
|
||||||
nullResultHandler e@(FieldException fieldLocation errorPath' next) =
|
nullResultHandler e@(FieldException fieldLocation errorPath' next) =
|
||||||
let newError = constructError next fieldLocation errorPath'
|
let newError = constructError next fieldLocation errorPath'
|
||||||
in if Out.isNonNullType fieldType
|
in if Out.isNonNullType fieldType
|
||||||
then throwM e
|
then throwM e
|
||||||
else returnError newError
|
else returnError newError
|
||||||
|
exceptionHandler :: (Exception e, MonadCatch m, Serialize a)
|
||||||
|
=> Full.Location
|
||||||
|
-> ExecuteHandler m a e
|
||||||
exceptionHandler errorLocation e =
|
exceptionHandler errorLocation e =
|
||||||
let newError = constructError e errorLocation fieldErrorPath
|
let newError = constructError e errorLocation fieldErrorPath
|
||||||
in if Out.isNonNullType fieldType
|
in if Out.isNonNullType fieldType
|
||||||
|
@ -1,48 +0,0 @@
|
|||||||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
|
||||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
|
||||||
|
|
||||||
-- | Template Haskell helpers.
|
|
||||||
module Language.GraphQL.TH
|
|
||||||
( gql
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
|
||||||
import Language.Haskell.TH (Exp(..), Lit(..))
|
|
||||||
|
|
||||||
stripIndentation :: String -> String
|
|
||||||
stripIndentation code = reverse
|
|
||||||
$ dropWhile isLineBreak
|
|
||||||
$ reverse
|
|
||||||
$ unlines
|
|
||||||
$ indent spaces <$> lines' withoutLeadingNewlines
|
|
||||||
where
|
|
||||||
indent 0 xs = xs
|
|
||||||
indent count (' ' : xs) = indent (count - 1) xs
|
|
||||||
indent _ xs = xs
|
|
||||||
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.
|
|
||||||
{-# DEPRECATED gql "Use Language.GraphQL.Class.gql from graphql-spice instead" #-}
|
|
||||||
gql :: QuasiQuoter
|
|
||||||
gql = QuasiQuoter
|
|
||||||
{ quoteExp = pure . LitE . StringL . stripIndentation
|
|
||||||
, quotePat = const
|
|
||||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"
|
|
||||||
, quoteType = const
|
|
||||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"
|
|
||||||
, quoteDec = const
|
|
||||||
$ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"
|
|
||||||
}
|
|
@ -3,6 +3,7 @@
|
|||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
|
|
||||||
-- | Types that can be used as both input and output types.
|
-- | Types that can be used as both input and output types.
|
||||||
|
@ -3,6 +3,7 @@
|
|||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||||
|
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
@ -210,7 +210,7 @@ typeDefinition context rule = \case
|
|||||||
Full.ObjectTypeDefinition _ _ _ directives' fields
|
Full.ObjectTypeDefinition _ _ _ directives' fields
|
||||||
-> directives context rule objectLocation directives'
|
-> directives context rule objectLocation directives'
|
||||||
>< foldMap (fieldDefinition context rule) fields
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
Full.InterfaceTypeDefinition _ _ directives' fields
|
Full.InterfaceTypeDefinition _ _ _ directives' fields
|
||||||
-> directives context rule interfaceLocation directives'
|
-> directives context rule interfaceLocation directives'
|
||||||
>< foldMap (fieldDefinition context rule) fields
|
>< foldMap (fieldDefinition context rule) fields
|
||||||
Full.UnionTypeDefinition _ _ directives' _ ->
|
Full.UnionTypeDefinition _ _ directives' _ ->
|
||||||
|
@ -137,25 +137,28 @@ singleFieldSubscriptionsRule :: forall m. Rule m
|
|||||||
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||||
Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
|
Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
|
||||||
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
|
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
|
||||||
case HashSet.size groupedFieldSet of
|
case HashSet.toList groupedFieldSet of
|
||||||
1 -> lift mempty
|
[rootName]
|
||||||
_
|
| Text.isPrefixOf "__" rootName -> makeError location' name'
|
||||||
| Just name <- name' -> pure $ Error
|
"exactly one top level field, which must not be an introspection field."
|
||||||
|
| otherwise -> lift mempty
|
||||||
|
[] -> makeError location' name' "exactly one top level field."
|
||||||
|
_ -> makeError location' name' "only one top level field."
|
||||||
|
_ -> lift mempty
|
||||||
|
where
|
||||||
|
makeError location' (Just operationName) errorLine = pure $ Error
|
||||||
{ message = concat
|
{ message = concat
|
||||||
[ "Subscription \""
|
[ "Subscription \""
|
||||||
, Text.unpack name
|
, Text.unpack operationName
|
||||||
, "\" must select only one top level field."
|
, "\" must select "
|
||||||
|
, errorLine
|
||||||
]
|
]
|
||||||
, locations = [location']
|
, locations = [location']
|
||||||
}
|
}
|
||||||
| otherwise -> pure $ Error
|
makeError location' Nothing errorLine = pure $ Error
|
||||||
{ message = errorMessage
|
{ message = "Anonymous Subscription must select " <> errorLine
|
||||||
, locations = [location']
|
, locations = [location']
|
||||||
}
|
}
|
||||||
_ -> lift mempty
|
|
||||||
where
|
|
||||||
errorMessage =
|
|
||||||
"Anonymous Subscription must select only one top level field."
|
|
||||||
collectFields = foldM forEach HashSet.empty
|
collectFields = foldM forEach HashSet.empty
|
||||||
forEach accumulator = \case
|
forEach accumulator = \case
|
||||||
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
|
||||||
@ -856,8 +859,8 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
|||||||
, "\"."
|
, "\"."
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | GraphQL servers define what directives they support. For each usage of a
|
-- | GraphQL services define what directives they support. For each usage of a
|
||||||
-- directive, the directive must be available on that server.
|
-- directive, the directive must be available on that service.
|
||||||
knownDirectiveNamesRule :: Rule m
|
knownDirectiveNamesRule :: Rule m
|
||||||
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
|
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
|
||||||
definitions' <- asks $ Schema.directives . schema
|
definitions' <- asks $ Schema.directives . schema
|
||||||
@ -909,9 +912,9 @@ knownInputFieldNamesRule = ValueRule go constGo
|
|||||||
, "\"."
|
, "\"."
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | GraphQL servers define what directives they support and where they support
|
-- | GraphQL services define what directives they support and where they support
|
||||||
-- them. For each usage of a directive, the directive must be used in a location
|
-- them. For each usage of a directive, the directive must be used in a location
|
||||||
-- that the server has declared support for.
|
-- that the service has declared support for.
|
||||||
directivesInValidLocationsRule :: Rule m
|
directivesInValidLocationsRule :: Rule m
|
||||||
directivesInValidLocationsRule = DirectivesRule directivesRule
|
directivesInValidLocationsRule = DirectivesRule directivesRule
|
||||||
where
|
where
|
||||||
@ -1064,18 +1067,12 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
|
|||||||
go selectionSet selectionType = do
|
go selectionSet selectionType = do
|
||||||
fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty
|
fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty
|
||||||
fieldsInSetCanMerge fieldTuples
|
fieldsInSetCanMerge fieldTuples
|
||||||
fieldsInSetCanMerge :: forall m
|
|
||||||
. HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
|
|
||||||
-> ReaderT (Validation m) Seq Error
|
|
||||||
fieldsInSetCanMerge fieldTuples = do
|
fieldsInSetCanMerge fieldTuples = do
|
||||||
validation <- ask
|
validation <- ask
|
||||||
let (lonely, paired) = flattenPairs fieldTuples
|
let (lonely, paired) = flattenPairs fieldTuples
|
||||||
let reader = flip runReaderT validation
|
let reader = flip runReaderT validation
|
||||||
lift $ foldMap (reader . visitLonelyFields) lonely
|
lift $ foldMap (reader . visitLonelyFields) lonely
|
||||||
<> foldMap (reader . forEachFieldTuple) paired
|
<> foldMap (reader . forEachFieldTuple) paired
|
||||||
forEachFieldTuple :: forall m
|
|
||||||
. (FieldInfo m, FieldInfo m)
|
|
||||||
-> ReaderT (Validation m) Seq Error
|
|
||||||
forEachFieldTuple (fieldA, fieldB) =
|
forEachFieldTuple (fieldA, fieldB) =
|
||||||
case (parent fieldA, parent fieldB) of
|
case (parent fieldA, parent fieldB) of
|
||||||
(parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{})
|
(parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{})
|
||||||
@ -1102,10 +1099,6 @@ overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
|
|||||||
let Full.Field _ _ _ _ subSelections _ = node
|
let Full.Field _ _ _ _ subSelections _ = node
|
||||||
compositeFieldType = Type.outToComposite type'
|
compositeFieldType = Type.outToComposite type'
|
||||||
in maybe (lift Seq.empty) (go subSelections) compositeFieldType
|
in maybe (lift Seq.empty) (go subSelections) compositeFieldType
|
||||||
sameResponseShape :: forall m
|
|
||||||
. FieldInfo m
|
|
||||||
-> FieldInfo m
|
|
||||||
-> ReaderT (Validation m) Seq Error
|
|
||||||
sameResponseShape fieldA fieldB =
|
sameResponseShape fieldA fieldB =
|
||||||
let Full.Field _ _ _ _ selectionsA _ = node fieldA
|
let Full.Field _ _ _ _ selectionsA _ = node fieldA
|
||||||
Full.Field _ _ _ _ selectionsB _ = node fieldB
|
Full.Field _ _ _ _ selectionsB _ = node fieldB
|
||||||
|
@ -181,7 +181,7 @@ spec = do
|
|||||||
argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
|
argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
|
||||||
arguments = Full.ArgumentsDefinition [argument]
|
arguments = Full.ArgumentsDefinition [argument]
|
||||||
definition' = Full.TypeDefinition
|
definition' = Full.TypeDefinition
|
||||||
$ Full.InterfaceTypeDefinition mempty "UUID" mempty
|
$ Full.InterfaceTypeDefinition mempty "UUID" (Full.ImplementsInterfaces []) mempty
|
||||||
$ pure
|
$ pure
|
||||||
$ Full.FieldDefinition mempty "value" arguments someType mempty
|
$ Full.FieldDefinition mempty "value" arguments someType mempty
|
||||||
expected = "interface UUID {\n\
|
expected = "interface UUID {\n\
|
||||||
|
@ -103,6 +103,12 @@ spec = describe "Parser" $ do
|
|||||||
\ name: String\n\
|
\ name: String\n\
|
||||||
\}"
|
\}"
|
||||||
|
|
||||||
|
it "parses ImplementsInterfaces on interfaces" $
|
||||||
|
parse document "" `shouldSucceedOn`
|
||||||
|
"interface Person implements NamedEntity & ValuedEntity {\n\
|
||||||
|
\ name: String\n\
|
||||||
|
\}"
|
||||||
|
|
||||||
it "parses minimal enum type definition" $
|
it "parses minimal enum type definition" $
|
||||||
parse document "" `shouldSucceedOn`
|
parse document "" `shouldSucceedOn`
|
||||||
"enum Direction {\n\
|
"enum Direction {\n\
|
||||||
|
@ -1,24 +0,0 @@
|
|||||||
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
|
||||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
|
||||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
|
||||||
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
|
|
||||||
module Language.GraphQL.THSpec
|
|
||||||
( spec
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Language.GraphQL.TH (gql)
|
|
||||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec =
|
|
||||||
describe "gql" $
|
|
||||||
it "replaces CRNL with NL" $
|
|
||||||
let expected = "line1\nline2\nline3"
|
|
||||||
actual = [gql|
|
|
||||||
line1
|
|
||||||
line2
|
|
||||||
line3
|
|
||||||
|]
|
|
||||||
in actual `shouldBe` expected
|
|
@ -94,7 +94,7 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
|||||||
, ("nickname", nicknameResolver)
|
, ("nickname", nicknameResolver)
|
||||||
, ("barkVolume", barkVolumeResolver)
|
, ("barkVolume", barkVolumeResolver)
|
||||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
, ("doesKnowCommand", doesKnowCommandResolver)
|
||||||
, ("isHousetrained", isHousetrainedResolver)
|
, ("isHouseTrained", isHouseTrainedResolver)
|
||||||
, ("owner", ownerResolver)
|
, ("owner", ownerResolver)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
@ -105,10 +105,10 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
|||||||
$ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
|
$ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
|
||||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
||||||
$ pure $ Boolean True
|
$ pure $ Boolean True
|
||||||
isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)
|
isHouseTrainedField = Field Nothing (Out.NonNullScalarType boolean)
|
||||||
$ HashMap.singleton "atOtherHomes"
|
$ HashMap.singleton "atOtherHomes"
|
||||||
$ In.Argument Nothing (In.NamedScalarType boolean) Nothing
|
$ In.Argument Nothing (In.NamedScalarType boolean) Nothing
|
||||||
isHousetrainedResolver = ValueResolver isHousetrainedField
|
isHouseTrainedResolver = ValueResolver isHouseTrainedField
|
||||||
$ pure $ Boolean True
|
$ pure $ Boolean True
|
||||||
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
||||||
ownerResolver = ValueResolver ownerField $ pure Null
|
ownerResolver = ValueResolver ownerField $ pure Null
|
||||||
@ -206,6 +206,18 @@ spec =
|
|||||||
}
|
}
|
||||||
in validate queryString `shouldContain` [expected]
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
|
it "rejects an introspection field as the subscription root" $
|
||||||
|
let queryString = "subscription sub {\n\
|
||||||
|
\ __typename\n\
|
||||||
|
\}"
|
||||||
|
expected = Error
|
||||||
|
{ message =
|
||||||
|
"Subscription \"sub\" must select exactly one top \
|
||||||
|
\level field, which must not be an introspection field."
|
||||||
|
, locations = [AST.Location 1 1]
|
||||||
|
}
|
||||||
|
in validate queryString `shouldContain` [expected]
|
||||||
|
|
||||||
it "rejects multiple subscription root fields coming from a fragment" $
|
it "rejects multiple subscription root fields coming from a fragment" $
|
||||||
let queryString = "subscription sub {\n\
|
let queryString = "subscription sub {\n\
|
||||||
\ ...multipleSubscriptions\n\
|
\ ...multipleSubscriptions\n\
|
||||||
@ -455,7 +467,7 @@ spec =
|
|||||||
it "rejects duplicate field arguments" $
|
it "rejects duplicate field arguments" $
|
||||||
let queryString = "{\n\
|
let queryString = "{\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: true, atOtherHomes: true)\n\
|
\ isHouseTrained(atOtherHomes: true, atOtherHomes: true)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -492,7 +504,7 @@ spec =
|
|||||||
it "rejects duplicate variables" $
|
it "rejects duplicate variables" $
|
||||||
let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\
|
let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: $atOtherHomes)\n\
|
\ isHouseTrained(atOtherHomes: $atOtherHomes)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -507,7 +519,7 @@ spec =
|
|||||||
it "rejects non-input types as variables" $
|
it "rejects non-input types as variables" $
|
||||||
let queryString = "query takesDogBang($dog: Dog!) {\n\
|
let queryString = "query takesDogBang($dog: Dog!) {\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: $dog)\n\
|
\ isHouseTrained(atOtherHomes: $dog)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -522,12 +534,12 @@ spec =
|
|||||||
it "rejects undefined variables" $
|
it "rejects undefined variables" $
|
||||||
let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\
|
let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ ...isHousetrainedFragment\n\
|
\ ...isHouseTrainedFragment\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}\n\
|
\}\n\
|
||||||
\\n\
|
\\n\
|
||||||
\fragment isHousetrainedFragment on Dog {\n\
|
\fragment isHouseTrainedFragment on Dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: $atOtherHomes)\n\
|
\ isHouseTrained(atOtherHomes: $atOtherHomes)\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
{ message =
|
{ message =
|
||||||
@ -566,7 +578,7 @@ spec =
|
|||||||
it "rejects unused variables" $
|
it "rejects unused variables" $
|
||||||
let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\
|
let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained\n\
|
\ isHouseTrained\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -648,7 +660,7 @@ spec =
|
|||||||
it "rejects directive arguments missing in the definition" $
|
it "rejects directive arguments missing in the definition" $
|
||||||
let queryString = "{\n\
|
let queryString = "{\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: true) @include(unless: false, if: true)\n\
|
\ isHouseTrained(atOtherHomes: true) @include(unless: false, if: true)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -663,7 +675,7 @@ spec =
|
|||||||
it "rejects undefined directives" $
|
it "rejects undefined directives" $
|
||||||
let queryString = "{\n\
|
let queryString = "{\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: true) @ignore(if: true)\n\
|
\ isHouseTrained(atOtherHomes: true) @ignore(if: true)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -740,13 +752,13 @@ spec =
|
|||||||
let queryString = "{\n\
|
let queryString = "{\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ doesKnowCommand(dogCommand: SIT)\n\
|
\ doesKnowCommand(dogCommand: SIT)\n\
|
||||||
\ doesKnowCommand: isHousetrained(atOtherHomes: true)\n\
|
\ doesKnowCommand: isHouseTrained(atOtherHomes: true)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
{ message =
|
{ message =
|
||||||
"Fields \"doesKnowCommand\" conflict because \
|
"Fields \"doesKnowCommand\" conflict because \
|
||||||
\\"doesKnowCommand\" and \"isHousetrained\" are \
|
\\"doesKnowCommand\" and \"isHouseTrained\" are \
|
||||||
\different fields. Use different aliases on the \
|
\different fields. Use different aliases on the \
|
||||||
\fields to fetch both if this was intentional."
|
\fields to fetch both if this was intentional."
|
||||||
, locations = [AST.Location 3 5, AST.Location 4 5]
|
, locations = [AST.Location 3 5, AST.Location 4 5]
|
||||||
@ -761,13 +773,13 @@ spec =
|
|||||||
\ }\n\
|
\ }\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ name\n\
|
\ name\n\
|
||||||
\ doesKnowCommand: isHousetrained(atOtherHomes: true)\n\
|
\ doesKnowCommand: isHouseTrained(atOtherHomes: true)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
{ message =
|
{ message =
|
||||||
"Fields \"doesKnowCommand\" conflict because \
|
"Fields \"doesKnowCommand\" conflict because \
|
||||||
\\"doesKnowCommand\" and \"isHousetrained\" are \
|
\\"doesKnowCommand\" and \"isHouseTrained\" are \
|
||||||
\different fields. Use different aliases on the \
|
\different fields. Use different aliases on the \
|
||||||
\fields to fetch both if this was intentional."
|
\fields to fetch both if this was intentional."
|
||||||
, locations = [AST.Location 4 5, AST.Location 8 5]
|
, locations = [AST.Location 4 5, AST.Location 8 5]
|
||||||
@ -860,7 +872,7 @@ spec =
|
|||||||
it "rejects wrongly typed variable arguments" $
|
it "rejects wrongly typed variable arguments" $
|
||||||
let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\
|
let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: $intArg)\n\
|
\ isHouseTrained(atOtherHomes: $intArg)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
@ -875,7 +887,7 @@ spec =
|
|||||||
it "rejects values of incorrect types" $
|
it "rejects values of incorrect types" $
|
||||||
let queryString = "{\n\
|
let queryString = "{\n\
|
||||||
\ dog {\n\
|
\ dog {\n\
|
||||||
\ isHousetrained(atOtherHomes: 3)\n\
|
\ isHouseTrained(atOtherHomes: 3)\n\
|
||||||
\ }\n\
|
\ }\n\
|
||||||
\}"
|
\}"
|
||||||
expected = Error
|
expected = Error
|
||||||
|
Loading…
x
Reference in New Issue
Block a user