Compare commits
7 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | a2401d563b | |
Dmitrii Skurikhin | 8503c0f288 | |
Dmitrii Skurikhin | 05e6aa4c95 | |
Eugen Wissner | 647547206f | |
Dmitrii Skurikhin | 0c8edae90a | |
Eugen Wissner | 73585dde85 | |
Dmitrii Skurikhin | 1f7bd92d11 |
12
CHANGELOG.md
12
CHANGELOG.md
|
@ -6,6 +6,17 @@ The format is based on
|
|||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [1.0.3.0] - 2022-03-27
|
||||
### Fixed
|
||||
- Index position in error path. (Index and Segment paths of a field have been
|
||||
swapped).
|
||||
- Parsing empty list as an argument.
|
||||
|
||||
### Added
|
||||
- quickCheck Parser test for arguments. Arbitrary instances for Language.GraphQL.AST.Document.
|
||||
- Enhanced query error messages. Add tests for these cases.
|
||||
- Allow version 2.0 of the text package.
|
||||
|
||||
## [1.0.2.0] - 2021-12-26
|
||||
### Added
|
||||
- `Serialize` instance for `Type.Definition.Value`.
|
||||
|
@ -466,6 +477,7 @@ and this project adheres to
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.3.0&rev_to=v1.0.2.0
|
||||
[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.2.0&rev_to=v1.0.1.0
|
||||
[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0
|
||||
[1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
cabal-version: 2.4
|
||||
|
||||
name: graphql
|
||||
version: 1.0.2.0
|
||||
version: 1.0.3.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
|
||||
category: Language
|
||||
|
@ -22,8 +22,7 @@ extra-source-files:
|
|||
README.md
|
||||
tested-with:
|
||||
GHC == 8.10.7,
|
||||
GHC == 9.0.1,
|
||||
GHC == 9.2.1
|
||||
GHC == 9.2.2
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
@ -72,7 +71,7 @@ library
|
|||
megaparsec >= 9.0 && < 10,
|
||||
parser-combinators >= 1.3 && < 2,
|
||||
template-haskell >= 2.16 && < 3,
|
||||
text ^>= 1.2.4,
|
||||
text >= 1.2 && < 3,
|
||||
transformers ^>= 0.5.6,
|
||||
unordered-containers ^>= 0.2.14,
|
||||
vector ^>= 0.12.3
|
||||
|
@ -93,12 +92,14 @@ test-suite graphql-test
|
|||
Language.GraphQL.AST.EncoderSpec
|
||||
Language.GraphQL.AST.LexerSpec
|
||||
Language.GraphQL.AST.ParserSpec
|
||||
Language.GraphQL.AST.Arbitrary
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.Execute.CoerceSpec
|
||||
Language.GraphQL.Execute.OrderedMapSpec
|
||||
Language.GraphQL.ExecuteSpec
|
||||
Language.GraphQL.Type.OutSpec
|
||||
Language.GraphQL.Validate.RulesSpec
|
||||
Schemas.HeroSchema
|
||||
hs-source-dirs:
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
|
||||
|
@ -113,5 +114,7 @@ test-suite graphql-test
|
|||
hspec-megaparsec ^>= 2.2.0,
|
||||
megaparsec,
|
||||
text,
|
||||
unordered-containers
|
||||
unordered-containers,
|
||||
containers,
|
||||
vector
|
||||
default-language: Haskell2010
|
||||
|
|
|
@ -1,9 +1,8 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
|
||||
#ifdef WITH_JSON
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
#ifdef WITH_JSON
|
||||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
module Language.GraphQL
|
||||
( graphql
|
||||
|
@ -79,6 +78,46 @@ graphqlSubs schema operationName variableValues document' =
|
|||
#else
|
||||
-- | This module provides the functions to parse and execute @GraphQL@ queries.
|
||||
module Language.GraphQL
|
||||
(
|
||||
( graphql
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import qualified Language.GraphQL.Validate as Validate
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import Prelude hiding (null)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema'.
|
||||
--
|
||||
-- An operation name can be given if the document contains multiple operations.
|
||||
graphql :: (MonadCatch m, VariableValue a, Serialize b)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> HashMap Full.Name a -- ^ Variable substitution function.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m (Either (ResponseEventStream m b) (Response b)) -- ^ Response.
|
||||
graphql schema operationName variableValues document' =
|
||||
case parse Full.document "" document' of
|
||||
Left errorBundle -> pure <$> parseError errorBundle
|
||||
Right parsed ->
|
||||
case validate parsed of
|
||||
Seq.Empty -> execute schema operationName variableValues parsed
|
||||
errors -> pure $ pure
|
||||
$ Response null
|
||||
$ fromValidationError <$> errors
|
||||
where
|
||||
validate = Validate.document schema Validate.specifiedRules
|
||||
fromValidationError Validate.Error{..} = Error
|
||||
{ message = Text.pack message
|
||||
, locations = locations
|
||||
, path = []
|
||||
}
|
||||
#endif
|
||||
|
|
|
@ -49,6 +49,8 @@ module Language.GraphQL.AST.Document
|
|||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
, escape
|
||||
, showVariableName
|
||||
, showVariable
|
||||
) where
|
||||
|
||||
import Data.Char (ord)
|
||||
|
@ -339,6 +341,12 @@ data VariableDefinition =
|
|||
VariableDefinition Name Type (Maybe (Node ConstValue)) Location
|
||||
deriving (Eq, Show)
|
||||
|
||||
showVariableName :: VariableDefinition -> String
|
||||
showVariableName (VariableDefinition name _ _ _) = "$" <> Text.unpack name
|
||||
|
||||
showVariable :: VariableDefinition -> String
|
||||
showVariable var@(VariableDefinition _ type' _ _) = showVariableName var <> ":" <> " " <> show type'
|
||||
|
||||
-- ** Type References
|
||||
|
||||
-- | Type representation.
|
||||
|
|
|
@ -450,8 +450,8 @@ value = Full.Variable <$> variable
|
|||
<|> Full.Null <$ nullValue
|
||||
<|> Full.String <$> stringValue
|
||||
<|> Full.Enum <$> try enumValue
|
||||
<|> Full.List <$> brackets (some $ valueNode value)
|
||||
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
|
||||
<|> Full.List <$> brackets (many $ valueNode value)
|
||||
<|> Full.Object <$> braces (many $ objectField $ valueNode value)
|
||||
<?> "Value"
|
||||
|
||||
constValue :: Parser Full.ConstValue
|
||||
|
|
|
@ -61,6 +61,7 @@ import Language.GraphQL.Error
|
|||
, ResponseEventStream
|
||||
)
|
||||
import Prelude hiding (null)
|
||||
import Language.GraphQL.AST.Document (showVariableName)
|
||||
|
||||
newtype ExecutorT m a = ExecutorT
|
||||
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
|
||||
|
@ -190,32 +191,42 @@ data QueryError
|
|||
tell :: Monad m => Seq Error -> ExecutorT m ()
|
||||
tell = ExecutorT . lift . Writer.tell
|
||||
|
||||
operationNameErrorText :: Text
|
||||
operationNameErrorText = Text.unlines
|
||||
[ "Named operations must be provided with the name of the desired operation."
|
||||
, "See https://spec.graphql.org/June2018/#sec-Language.Document description."
|
||||
]
|
||||
|
||||
queryError :: QueryError -> Error
|
||||
queryError OperationNameRequired =
|
||||
Error{ message = "Operation name is required.", locations = [], path = [] }
|
||||
let queryErrorMessage = "Operation name is required. " <> operationNameErrorText
|
||||
in Error{ message = queryErrorMessage, locations = [], path = [] }
|
||||
queryError (OperationNotFound operationName) =
|
||||
let queryErrorMessage = Text.concat
|
||||
[ "Operation \""
|
||||
, Text.pack operationName
|
||||
, "\" not found."
|
||||
let queryErrorMessage = Text.unlines
|
||||
[ Text.concat
|
||||
[ "Operation \""
|
||||
, Text.pack operationName
|
||||
, "\" is not found in the named operations you've provided. "
|
||||
]
|
||||
, operationNameErrorText
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [], path = [] }
|
||||
queryError (CoercionError variableDefinition) =
|
||||
let Full.VariableDefinition variableName _ _ location = variableDefinition
|
||||
let (Full.VariableDefinition _ _ _ location) = variableDefinition
|
||||
queryErrorMessage = Text.concat
|
||||
[ "Failed to coerce the variable \""
|
||||
, variableName
|
||||
, "\"."
|
||||
[ "Failed to coerce the variable "
|
||||
, Text.pack $ Full.showVariable variableDefinition
|
||||
, "."
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [location], path = [] }
|
||||
queryError (UnknownInputType variableDefinition) =
|
||||
let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
|
||||
let Full.VariableDefinition _ variableTypeName _ location = variableDefinition
|
||||
queryErrorMessage = Text.concat
|
||||
[ "Variable \""
|
||||
, variableName
|
||||
, "\" has unknown type \""
|
||||
[ "Variable "
|
||||
, Text.pack $ showVariableName variableDefinition
|
||||
, " has unknown type "
|
||||
, Text.pack $ show variableTypeName
|
||||
, "\"."
|
||||
, "."
|
||||
]
|
||||
in Error{ message = queryErrorMessage, locations = [location], path = [] }
|
||||
|
||||
|
@ -375,6 +386,7 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
|
|||
, Handler (resolverHandler fieldLocation)
|
||||
]
|
||||
where
|
||||
fieldErrorPath = fieldsSegment fields : errorPath
|
||||
inputCoercionHandler :: (MonadCatch m, Serialize a)
|
||||
=> Full.Location
|
||||
-> InputCoercionException
|
||||
|
@ -402,17 +414,16 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
|
|||
then throwM e
|
||||
else returnError newError
|
||||
exceptionHandler errorLocation e =
|
||||
let newPath = fieldsSegment fields : errorPath
|
||||
newError = constructError e errorLocation newPath
|
||||
let newError = constructError e errorLocation fieldErrorPath
|
||||
in if Out.isNonNullType fieldType
|
||||
then throwM $ FieldException errorLocation newPath e
|
||||
then throwM $ FieldException errorLocation fieldErrorPath e
|
||||
else returnError newError
|
||||
returnError newError = tell (Seq.singleton newError) >> pure null
|
||||
go fieldName inputArguments = do
|
||||
argumentValues <- coerceArgumentValues argumentTypes inputArguments
|
||||
resolvedValue <-
|
||||
resolveFieldValue resolveFunction objectValue fieldName argumentValues
|
||||
completeValue fieldType fields errorPath resolvedValue
|
||||
completeValue fieldType fields fieldErrorPath resolvedValue
|
||||
(resolverField, resolveFunction) = resolverPair
|
||||
Out.Field _ fieldType argumentTypes = resolverField
|
||||
|
||||
|
@ -445,6 +456,7 @@ resolveAbstractType abstractType values'
|
|||
_ -> pure Nothing
|
||||
| otherwise = pure Nothing
|
||||
|
||||
-- https://spec.graphql.org/October2021/#sec-Value-Completion
|
||||
completeValue :: (MonadCatch m, Serialize a)
|
||||
=> Out.Type m
|
||||
-> NonEmpty (Transform.Field m)
|
||||
|
@ -476,8 +488,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
|
|||
$ ValueCompletionException (show outputType)
|
||||
$ Type.Enum enum
|
||||
completeValue (Out.ObjectBaseType objectType) fields errorPath result
|
||||
= executeSelectionSet (mergeSelectionSets fields) objectType result
|
||||
$ fieldsSegment fields : errorPath
|
||||
= executeSelectionSet (mergeSelectionSets fields) objectType result errorPath
|
||||
completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = Type.Internal.AbstractInterfaceType interfaceType
|
||||
|
|
|
@ -0,0 +1,99 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Language.GraphQL.AST.Arbitrary where
|
||||
|
||||
import qualified Language.GraphQL.AST.Document as Doc
|
||||
import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
|
||||
import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..))
|
||||
import Test.QuickCheck.Gen (Gen (..))
|
||||
import Data.Text (Text, pack)
|
||||
|
||||
newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
|
||||
|
||||
alpha :: String
|
||||
alpha = ['a'..'z'] <> ['A'..'Z']
|
||||
|
||||
num :: String
|
||||
num = ['0'..'9']
|
||||
|
||||
instance Arbitrary AnyPrintableChar where
|
||||
arbitrary = AnyPrintableChar <$> elements chars
|
||||
where
|
||||
chars = alpha <> num <> ['_']
|
||||
|
||||
newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyPrintableText where
|
||||
arbitrary = do
|
||||
nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar))
|
||||
pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr)
|
||||
|
||||
-- https://spec.graphql.org/June2018/#Name
|
||||
newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyName where
|
||||
arbitrary = do
|
||||
firstChar <- elements $ alpha <> ['_']
|
||||
rest <- (arbitrary :: Gen [AnyPrintableChar])
|
||||
pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest)
|
||||
|
||||
newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyLocation where
|
||||
arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary)
|
||||
|
||||
newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyNode a) where
|
||||
arbitrary = do
|
||||
(AnyLocation location') <- arbitrary
|
||||
node' <- flip Doc.Node location' <$> arbitrary
|
||||
pure $ AnyNode node'
|
||||
|
||||
newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyObjectField a) where
|
||||
arbitrary = do
|
||||
name' <- getAnyName <$> arbitrary
|
||||
value' <- getAnyNode <$> arbitrary
|
||||
location' <- getAnyLocation <$> arbitrary
|
||||
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
|
||||
|
||||
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary AnyValue where
|
||||
arbitrary = AnyValue <$> oneof
|
||||
[ variableGen
|
||||
, Doc.Int <$> arbitrary
|
||||
, Doc.Float <$> arbitrary
|
||||
, Doc.String <$> (getAnyPrintableText <$> arbitrary)
|
||||
, Doc.Boolean <$> arbitrary
|
||||
, MkGen $ \_ _ -> Doc.Null
|
||||
, Doc.Enum <$> (getAnyName <$> arbitrary)
|
||||
, Doc.List <$> listGen
|
||||
, Doc.Object <$> objectGen
|
||||
]
|
||||
where
|
||||
variableGen :: Gen Doc.Value
|
||||
variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
|
||||
listGen :: Gen [Doc.Node Doc.Value]
|
||||
listGen = (resize 5 . listOf) nodeGen
|
||||
nodeGen = do
|
||||
node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
|
||||
pure (getAnyValue <$> node')
|
||||
objectGen :: Gen [Doc.ObjectField Doc.Value]
|
||||
objectGen = resize 1 $ do
|
||||
list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
|
||||
pure $ map (fmap getAnyValue . getAnyObjectField) list
|
||||
|
||||
newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary a => Arbitrary (AnyArgument a) where
|
||||
arbitrary = do
|
||||
name' <- getAnyName <$> arbitrary
|
||||
(AnyValue value') <- arbitrary
|
||||
(AnyLocation location') <- arbitrary
|
||||
pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location'
|
||||
|
||||
printArgument :: AnyArgument AnyValue -> Text
|
||||
printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value'
|
|
@ -5,46 +5,78 @@ module Language.GraphQL.AST.ParserSpec
|
|||
) where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Language.GraphQL.TH
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec (Spec, describe, it, context)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
import Text.Megaparsec (parse)
|
||||
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
|
||||
import Language.GraphQL.AST.Arbitrary
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Parser" $ do
|
||||
it "accepts BOM header" $
|
||||
parse document "" `shouldSucceedOn` "\xfeff{foo}"
|
||||
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: """Argument""")
|
||||
}|]
|
||||
context "Arguments" $ do
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: """Argument""")
|
||||
}|]
|
||||
|
||||
it "accepts strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: "Argument")
|
||||
}|]
|
||||
it "accepts strings as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(text: "Argument")
|
||||
}|]
|
||||
|
||||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth($username: String!, $password: String!){
|
||||
test
|
||||
}|]
|
||||
it "accepts int as argument1" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
user(id: 4)
|
||||
}|]
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: "username", password: "password")
|
||||
}|]
|
||||
it "accepts boolean as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
hello(flag: true) { field1 }
|
||||
}|]
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
it "accepts float as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
body(height: 172.5) { height }
|
||||
}|]
|
||||
|
||||
it "accepts empty list as argument" $
|
||||
parse document "" `shouldSucceedOn` [gql|{
|
||||
query(list: []) { field1 }
|
||||
}|]
|
||||
|
||||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth($username: String!, $password: String!){
|
||||
test
|
||||
}|]
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: "username", password: "password")
|
||||
}|]
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
|
||||
it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
|
||||
let
|
||||
query' :: Text
|
||||
arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
|
||||
query' = "query(" <> Text.intercalate ", " arguments <> ")" in
|
||||
parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
|
||||
|
||||
it "parses minimal schema definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]
|
||||
|
@ -95,16 +127,6 @@ spec = describe "Parser" $ do
|
|||
}
|
||||
|]
|
||||
|
||||
it "parses minimal enum type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal input object type definition" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
input Point2D {
|
||||
|
@ -202,6 +224,13 @@ spec = describe "Parser" $ do
|
|||
}
|
||||
|]
|
||||
|
||||
it "rejects empty selection set" $
|
||||
parse document "" `shouldFailOn` [gql|
|
||||
query {
|
||||
innerField {}
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses documents beginning with a comment" $
|
||||
parse document "" `shouldSucceedOn` [gql|
|
||||
"""
|
||||
|
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Language.GraphQL.ExecuteSpec
|
||||
( spec
|
||||
) where
|
||||
|
@ -20,12 +21,17 @@ import Language.GraphQL.Error
|
|||
import Language.GraphQL.Execute (execute)
|
||||
import Language.GraphQL.TH
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Prelude hiding (id)
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
import Schemas.HeroSchema (heroSchema)
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Text as Text
|
||||
|
||||
data PhilosopherException = PhilosopherException
|
||||
deriving Show
|
||||
|
@ -178,7 +184,7 @@ quoteType = Out.ObjectType "Quote" Nothing []
|
|||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
|
||||
schoolType :: EnumType
|
||||
schoolType :: Type.EnumType
|
||||
schoolType = EnumType "School" Nothing $ HashMap.fromList
|
||||
[ ("NOMINALISM", EnumValue Nothing)
|
||||
, ("REALISM", EnumValue Nothing)
|
||||
|
@ -186,12 +192,12 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
|
|||
]
|
||||
|
||||
type EitherStreamOrValue = Either
|
||||
(ResponseEventStream (Either SomeException) Value)
|
||||
(Response Value)
|
||||
(ResponseEventStream (Either SomeException) Type.Value)
|
||||
(Response Type.Value)
|
||||
|
||||
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute' =
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Value)
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
@ -335,6 +341,68 @@ spec =
|
|||
$ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
context "queryError" $ do
|
||||
let
|
||||
namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
|
||||
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
|
||||
startsWith :: Text.Text -> Text.Text -> Bool
|
||||
startsWith xs ys = Text.take (Text.length ys) xs == ys
|
||||
|
||||
it "throws operation name is required error" $
|
||||
let expectedErrorMessage :: Text.Text
|
||||
expectedErrorMessage = "Operation name is required"
|
||||
Right (Right (Response _ executionErrors)) = either (pure . parseError) execute' $ parse document "" twoQueries
|
||||
Error msg _ _ = Seq.index executionErrors 0
|
||||
in msg `startsWith` expectedErrorMessage `shouldBe` True
|
||||
|
||||
it "throws operation not found error" $
|
||||
let expectedErrorMessage :: Text.Text
|
||||
expectedErrorMessage = "Operation \"C\" is not found"
|
||||
execute'' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute'' = execute philosopherSchema (Just "C") (mempty :: HashMap Name Type.Value)
|
||||
Right (Right (Response _ executionErrors)) = either (pure . parseError) execute''
|
||||
$ parse document "" twoQueries
|
||||
Error msg _ _ = Seq.index executionErrors 0
|
||||
in msg `startsWith` expectedErrorMessage `shouldBe` True
|
||||
|
||||
it "throws variable coercion error" $
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Failed to coerce the variable $id: String."
|
||||
, locations =[Location 1 7]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
executeWithVars :: Document -> Either SomeException EitherStreamOrValue
|
||||
executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
|
||||
Right (Right actual) = either (pure . parseError) executeWithVars
|
||||
$ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "throws variable unkown input type error" $
|
||||
let data'' = Null
|
||||
executionErrors = pure $ Error
|
||||
{ message = "Variable $id has unknown type Cat."
|
||||
, locations =[Location 1 7]
|
||||
, path = []
|
||||
}
|
||||
expected = Response data'' executionErrors
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
|
||||
in actual `shouldBe` expected
|
||||
|
||||
context "Error path" $ do
|
||||
let executeHero :: Document -> Either SomeException EitherStreamOrValue
|
||||
executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Type.Value)
|
||||
|
||||
it "at the beggining of the list" $
|
||||
let Right (Right actual) = either (pure . parseError) executeHero
|
||||
$ parse document "" "{ hero(id: \"1\") { friends { name } } }"
|
||||
Response _ errors' = actual
|
||||
Error _ _ path' = fromJust $ Seq.lookup 0 errors'
|
||||
expected = [Segment "hero", Segment "friends", Index 0, Segment "name"]
|
||||
in path' `shouldBe` expected
|
||||
|
||||
context "Subscription" $
|
||||
it "subscribes" $
|
||||
let data'' = Object
|
||||
|
|
|
@ -0,0 +1,70 @@
|
|||
{- 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 OverloadedStrings #-}
|
||||
|
||||
module Schemas.HeroSchema (heroSchema) where
|
||||
|
||||
import Control.Exception (Exception(..), SomeException)
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Language.GraphQL.Error (ResolverException (..))
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type.Schema (schemaWithTypes)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Typeable (cast)
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
data HeroException = HeroException
|
||||
deriving Show
|
||||
|
||||
instance Exception HeroException where
|
||||
toException = toException. ResolverException
|
||||
fromException e = do
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
heroSchema :: Type.Schema (Either SomeException)
|
||||
heroSchema =
|
||||
schemaWithTypes Nothing queryType Nothing Nothing [] mempty
|
||||
|
||||
type ObjectType = Out.ObjectType (Either SomeException)
|
||||
|
||||
queryType :: ObjectType
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("hero", Out.ValueResolver heroField heroResolver)
|
||||
]
|
||||
where
|
||||
heroField = Out.Field Nothing (Out.NamedObjectType heroType)
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
|
||||
heroResolver = pure $ Type.Object mempty
|
||||
|
||||
stringField :: Out.Field (Either SomeException)
|
||||
stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
|
||||
|
||||
heroType :: ObjectType
|
||||
heroType = Out.ObjectType "Hero" Nothing [] $ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("id", Out.ValueResolver stringField (pure $ Type.String "4111"))
|
||||
, ("name", Out.ValueResolver stringField (pure $ Type.String "R2D2"))
|
||||
, ("friends", Out.ValueResolver friendsField (pure $ Type.List [luke]))
|
||||
]
|
||||
friendsField = Out.Field Nothing (Out.ListType $ Out.NonNullObjectType lukeType) HashMap.empty
|
||||
-- This list values are ignored because of current realisation (types and resolvers are the same entity)
|
||||
-- The values from lukeType will be used
|
||||
luke = Type.Object $ HashMap.fromList
|
||||
[ ("id", "dfdfdf")
|
||||
, ("name", "dfdfdff")
|
||||
]
|
||||
|
||||
lukeType :: ObjectType
|
||||
lukeType = Out.ObjectType "Luke" Nothing [] $ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("id", Out.ValueResolver stringField (pure $ Type.String "1000"))
|
||||
, ("name", Out.ValueResolver stringField (throwM HeroException))
|
||||
]
|
Loading…
Reference in New Issue