graphql 1.0.2.0 → 1.0.3.0
raw patch · 10 files changed
+407/−68 lines, 10 filesdep ~containersdep ~textdep ~vectorPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers, text, vector
API changes (from Hackage documentation)
+ Language.GraphQL.AST.Document: showVariable :: VariableDefinition -> String
+ Language.GraphQL.AST.Document: showVariableName :: VariableDefinition -> String
Files
- CHANGELOG.md +12/−0
- graphql.cabal +8/−5
- src/Language/GraphQL.hs +42/−3
- src/Language/GraphQL/AST/Document.hs +8/−0
- src/Language/GraphQL/AST/Parser.hs +2/−2
- src/Language/GraphQL/Execute.hs +31/−20
- tests/Language/GraphQL/AST/Arbitrary.hs +99/−0
- tests/Language/GraphQL/AST/ParserSpec.hs +63/−34
- tests/Language/GraphQL/ExecuteSpec.hs +72/−4
- tests/Schemas/HeroSchema.hs +70/−0
CHANGELOG.md view
@@ -6,6 +6,17 @@ 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 @@ ### 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
graphql.cabal view
@@ -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 @@ 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 @@ 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 @@ 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 @@ hspec-megaparsec ^>= 2.2.0, megaparsec, text,- unordered-containers+ unordered-containers,+ containers,+ vector default-language: Haskell2010
src/Language/GraphQL.hs view
@@ -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 @@ #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
src/Language/GraphQL/AST/Document.hs view
@@ -49,6 +49,8 @@ , Value(..) , VariableDefinition(..) , escape+ , showVariableName+ , showVariable ) where import Data.Char (ord)@@ -338,6 +340,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
src/Language/GraphQL/AST/Parser.hs view
@@ -450,8 +450,8 @@ <|> 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
src/Language/GraphQL/Execute.hs view
@@ -61,6 +61,7 @@ , 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 @@ 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 @@ , Handler (resolverHandler fieldLocation) ] where+ fieldErrorPath = fieldsSegment fields : errorPath inputCoercionHandler :: (MonadCatch m, Serialize a) => Full.Location -> InputCoercionException@@ -402,17 +414,16 @@ 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 @@ _ -> 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 @@ $ 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
+ tests/Language/GraphQL/AST/Arbitrary.hs view
@@ -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'
tests/Language/GraphQL/AST/ParserSpec.hs view
@@ -5,47 +5,79 @@ ) 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 @@ } |] - 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 {@@ -199,6 +221,13 @@ parse document "" `shouldFailOn` [gql| query ($book: String = "Zarathustra", $author: String = $book) { title+ }+ |]++ it "rejects empty selection set" $+ parse document "" `shouldFailOn` [gql|+ query {+ innerField {} } |]
tests/Language/GraphQL/ExecuteSpec.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+ module Language.GraphQL.ExecuteSpec ( spec ) where@@ -20,12 +21,17 @@ 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 @@ 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 @@ ] 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 =@@ -334,6 +340,68 @@ Right (Right actual) = either (pure . parseError) execute' $ 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" $
+ tests/Schemas/HeroSchema.hs view
@@ -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))+ ]