graphql 0.8.0.0 → 0.9.0.0

raw patch · 36 files changed

+1440/−758 lines, 36 filesdep +conduitdep +exceptionsdep −vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: conduit, exceptions

Dependencies removed: vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +57/−0
• README.md +4/−4
• docs/tutorial/tutorial.lhs +38/−60
• graphql.cabal +15/−9
• src/Language/GraphQL.hs +56/−13
• src/Language/GraphQL/AST.hs +3/−1
• src/Language/GraphQL/AST/Core.hs +0/−19
• src/Language/GraphQL/AST/Document.hs +11/−6
• src/Language/GraphQL/AST/Encoder.hs +21/−16
• src/Language/GraphQL/AST/Lexer.hs +2/−2
• src/Language/GraphQL/AST/Parser.hs +124/−92
• src/Language/GraphQL/Error.hs +71/−34
• src/Language/GraphQL/Execute.hs +31/−39
• src/Language/GraphQL/Execute/Execution.hs +47/−35
• src/Language/GraphQL/Execute/Subscribe.hs +97/−0
• src/Language/GraphQL/Execute/Transform.hs +16/−10
• src/Language/GraphQL/Trans.hs +0/−67
• src/Language/GraphQL/Type.hs +10/−0
• src/Language/GraphQL/Type/Definition.hs +62/−2
• src/Language/GraphQL/Type/Directive.hs +0/−57
• src/Language/GraphQL/Type/Internal.hs +91/−0
• src/Language/GraphQL/Type/Out.hs +58/−14
• src/Language/GraphQL/Type/Schema.hs +2/−81
• src/Language/GraphQL/Validate.hs +97/−0
• src/Language/GraphQL/Validate/Rules.hs +31/−0
• src/Test/Hspec/GraphQL.hs +40/−0
• tests/Language/GraphQL/AST/ParserSpec.hs +22/−2
• tests/Language/GraphQL/ErrorSpec.hs +3/−7
• tests/Language/GraphQL/ExecuteSpec.hs +72/−34
• tests/Language/GraphQL/ValidateSpec.hs +171/−0
• tests/Test/DirectiveSpec.hs +19/−17
• tests/Test/FragmentSpec.hs +48/−59
• tests/Test/RootOperationSpec.hs +22/−16
• tests/Test/StarWars/Data.hs +23/−9
• tests/Test/StarWars/QuerySpec.hs +5/−3
• tests/Test/StarWars/Schema.hs +71/−50

@@ -6,6 +6,62 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [Unreleased]+## Fixed+- Location of a parse error is returned in a singleton array with key+  `locations`.+- Parsing comments in the front of definitions.+- Some missing labels were added to the parsers, some labels were fixed to+  refer to the AST nodes being parsed. ++## Added+- `AST` reexports `AST.Parser`.+- `AST.Document.Location` is a token location as a line and column pair.+- `Execute` reexports `Execute.Coerce`.+- `Error.Error` is an error representation with a message and source location.+- `Error.Response` represents a result of running a GraphQL query.+- `Type.Schema` exports `Type` which lists all types possible in the schema.+- Parsing subscriptions (the execution always fails yet).+- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and+  `Type.Out.SourceEventStream` define subscription resolvers.+- `Error.ResolverException` is an exception that can be thrown by (field value+  and event stream) resolvers to signalize an error. Other exceptions will+  escape.+- `Test.Hspec.GraphQL` contains some test helpers.+- `Validate` contains the validator and standard rules.++## Changed+- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields+  have value resolvers, root subscription type resolvers need an additional+  resolver that creates an event stream. `Resolver` represents these differences+  now and pairs a field with the function(s). Resolvers don't have `ExceptT`,+  errors are handled with `MonadThrow`/`MonadCatch`.+- All code from `Trans` is moved to `Type.Out` and exported by `Type` and+  `Type.Out`.+- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.+  `AST` provides now only functionality related to parsing and encoding, as it+  should be.+- `Execute.execute` takes an additional argument, a possible operation name+  and returns either a stream or the response.+- `Error` module was changed to work with dedicated types for errors and the+  response instead of JSON.+- `graphqlSubs` takes an additional argument, the operation name. The type of+  variable names is changed back to JSON since it is a common format and it+  saves additional conversions. Custom format still can be used with the+  underlying functions (in the `Execute` module). The function returns either a+  a stream or the resolved value.+- `graphql` returns either a stream or the resolved value.+- The constraint of the base monad was changed to `MonadCatch` (and it implies+  `MonadThrow`).++## Removed+- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`+  represents possible resolver configurations.+- `Type.Out.Resolver`: It . Resolvers are a+  part of the fields and are called `Trans.ResolverT`.+- `Execute.executeWithName`. `Execute.execute` takes the operation name and+   completely replaces `executeWithName`.+ ## [0.8.0.0] - 2020-06-20 ### Fixed - The parser rejects variables when parsing defaultValue (DefaultValue). The@@ -267,6 +323,7 @@ ### Added - Data types for the GraphQL language. +[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...HEAD [0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0 [0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0

@@ -1,7 +1,7 @@ # Haskell GraphQL  [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)-[![Build Status](https://semaphoreci.com/api/v1/belka-ew/graphql/branches/master/badge.svg)](https://semaphoreci.com/belka-ew/graphql)+[![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22) [![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)  GraphQL implementation in Haskell.@@ -13,9 +13,9 @@  ## State of the work -For now this only provides a parser and a printer for the GraphQL query-language and allows to execute queries and mutations without the schema-validation step. But the idea is to be a Haskell port of+For now this only provides a parser and a printer for the GraphQL query language+and allows to execute queries and mutations using the given schema, but without+the validation step. But the idea is to be a Haskell port of [`graphql-js`](https://github.com/graphql/graphql-js).  For the list of currently missing features see issues marked as

@@ -5,11 +5,13 @@  == Getting started == -Welcome to graphql-haskell!+Welcome to GraphQL! -We have written a small tutorial to help you (and ourselves) understand the graphql package.+We have written a small tutorial to help you (and ourselves) understand the+graphql package. -Since this file is a literate haskell file, we start by importing some dependencies.+Since this file is a literate haskell file, we start by importing some+dependencies.  > {-# LANGUAGE OverloadedStrings #-} > module Main where@@ -23,75 +25,76 @@ > import Data.Time (getCurrentTime) > > import Language.GraphQL-> import Language.GraphQL.Trans > import Language.GraphQL.Type > import qualified Language.GraphQL.Type.Out as Out > > import Prelude hiding (putStrLn) + === First example === -Now, as our first example, we are going to look at the-example from [graphql.js](https://github.com/graphql/graphql-js).+Now, as our first example, we are going to look at the example from+[graphql.js](https://github.com/graphql/graphql-js).  First we build a GraphQL schema.  > schema1 :: Schema IO-> schema1 = Schema queryType Nothing+> schema1 = Schema+>   { query = queryType , mutation = Nothing , subscription = Nothing } > > queryType :: ObjectType IO > queryType = ObjectType "Query" Nothing [] >   $ HashMap.singleton "hello"->   $ Out.Resolver helloField hello+>   $ ValueResolver helloField hello > > helloField :: Field IO > helloField = Field Nothing (Out.NamedScalarType string) mempty >-> hello :: ActionT IO Value+> hello :: Resolve IO > hello = pure $ String "it's me" -This defines a simple schema with one type and one field, that resolves to a fixed value.+This defines a simple schema with one type and one field, that resolves to a+fixed value.  Next we define our query.  > query1 :: Text > query1 = "{ hello }" - To run the query, we call the `graphql` with the schema and the query.  > main1 :: IO ()-> main1 = graphql schema1 query1 >>= putStrLn . encode+> main1 = graphql schema1 query1+>   >>= either (const $ pure ()) (putStrLn . encode) -This runs the query by fetching the one field defined,-returning+This runs the query by fetching the one field defined, returning  ```{"data" : {"hello":"it's me"}}```  - === Monadic actions ===  For this example, we're going to be using time.  > schema2 :: Schema IO-> schema2 = Schema queryType2 Nothing+> schema2 = Schema+>   { query = queryType2, mutation = Nothing, subscription = Nothing } > > queryType2 :: ObjectType IO > queryType2 = ObjectType "Query" Nothing [] >   $ HashMap.singleton "time"->   $ Out.Resolver timeField time+>   $ ValueResolver timeField time > > timeField :: Field IO > timeField = Field Nothing (Out.NamedScalarType string) mempty >-> time :: ActionT IO Value+> time :: Resolve IO > time = do >   t <- liftIO getCurrentTime >   pure $ String $ Text.pack $ show t -This defines a simple schema with one type and one field,-which resolves to the current time.+This defines a simple schema with one type and one field, which resolves to the+current time.  Next we define our query. @@ -99,76 +102,51 @@ > query2 = "{ time }" > > main2 :: IO ()-> main2 = graphql schema2 query2 >>= putStrLn . encode+> main2 = graphql schema2 query2+>   >>= either (const $ pure ()) (putStrLn . encode)  This runs the query, returning the current time  ```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```  -=== Errors ===--Errors are handled according to the spec,-with fields that cause erros being resolved to `null`,-and an error being added to the error list.--An example of this is the following query:--> queryShouldFail :: Text-> queryShouldFail = "{ boyhowdy }"--Since there is no `boyhowdy` field in our schema, it will not resolve,-and the query will fail, as we can see in the following example.--> mainShouldFail :: IO ()-> mainShouldFail = do->   success <- graphql schema1 query1->   putStrLn $ encode success->   putStrLn "This will fail"->   failure <- graphql schema1 queryShouldFail->   putStrLn $ encode failure->--This outputs:--```-{"data": {"hello": "it's me"}}-This will fail-{"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]}-```- === Combining resolvers ===  Now that we have two resolvers, we can define a schema which uses them both.  > schema3 :: Schema IO-> schema3 = Schema queryType3 Nothing+> schema3 = Schema+>   { query = queryType3, mutation = Nothing, subscription = Nothing } > > queryType3 :: ObjectType IO > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList->   [ ("hello", Out.Resolver helloField hello)->   , ("time", Out.Resolver timeField time)+>   [ ("hello", ValueResolver helloField hello)+>   , ("time", ValueResolver timeField time) >   ] > > query3 :: Text > query3 = "query timeAndHello { time hello }" > > main3 :: IO ()-> main3 = graphql schema3 query3 >>= putStrLn . encode+> main3 = graphql schema3 query3+>   >>= either (const $ pure ()) (putStrLn . encode)  This queries for both time and hello, returning  ```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}``` -Notice that we can name our queries, as we did with `timeAndHello`. Since we have only been using single queries, we can use the shorthand `{ time hello}`, as we have been doing in the previous examples.+Notice that we can name our queries, as we did with `timeAndHello`. Since we+have only been using single queries, we can use the shorthand `{ time hello }`,+as we have been doing in the previous examples.  In GraphQL there can only be one operation per query.   == Further examples == -More examples on queries and a more complex schema can be found in the test directory,-in the [Test.StarWars](../../tests/Test/StarWars) module. This includes a more complex schema, and more complex queries.+More examples on queries and a more complex schema can be found in the test+directory, in the [Test.StarWars](../../tests/Test/StarWars) module. This+includes a more complex schema, and more complex queries.  > main :: IO ()-> main = main1 >> main2 >> mainShouldFail >> main3+> main = main1 >> main2 >> main3

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: graphql-version: 0.8.0.0+version: 0.9.0.0 license: BSD3 license-file: LICENSE copyright: (c) 2019-2020 Eugen Wissner,@@ -33,7 +33,6 @@     exposed-modules:         Language.GraphQL         Language.GraphQL.AST-        Language.GraphQL.AST.Core         Language.GraphQL.AST.DirectiveLocation         Language.GraphQL.AST.Document         Language.GraphQL.AST.Encoder@@ -42,29 +41,34 @@         Language.GraphQL.Error         Language.GraphQL.Execute         Language.GraphQL.Execute.Coerce-        Language.GraphQL.Trans         Language.GraphQL.Type         Language.GraphQL.Type.In         Language.GraphQL.Type.Out+        Language.GraphQL.Type.Schema+        Language.GraphQL.Validate+        Test.Hspec.GraphQL     hs-source-dirs: src     other-modules:         Language.GraphQL.Execute.Execution+        Language.GraphQL.Execute.Subscribe         Language.GraphQL.Execute.Transform         Language.GraphQL.Type.Definition-        Language.GraphQL.Type.Directive-        Language.GraphQL.Type.Schema+        Language.GraphQL.Type.Internal+        Language.GraphQL.Validate.Rules     default-language: Haskell2010     build-depends:         aeson >=1.4.7.1 && <1.5,         base >=4.7 && <5,+        conduit >=1.3.2 && <1.4,         containers >=0.6.2.1 && <0.7,+        exceptions >=0.10.4 && <0.11,+        hspec-expectations >=0.8.2 && <0.9,         megaparsec >=8.0.0 && <8.1,         parser-combinators >=1.2.1 && <1.3,         scientific >=0.3.6.2 && <0.4,         text >=1.2.4.0 && <1.3,         transformers >=0.5.6.2 && <0.6,-        unordered-containers >=0.2.10.0 && <0.3,-        vector >=0.12.1.2 && <0.13+        unordered-containers >=0.2.10.0 && <0.3  test-suite tasty     type: exitcode-stdio-1.0@@ -78,6 +82,7 @@         Language.GraphQL.Execute.CoerceSpec         Language.GraphQL.ExecuteSpec         Language.GraphQL.Type.OutSpec+        Language.GraphQL.ValidateSpec         Test.DirectiveSpec         Test.FragmentSpec         Test.KitchenSinkSpec@@ -92,7 +97,9 @@         QuickCheck >=2.13.2 && <2.14,         aeson >=1.4.7.1 && <1.5,         base >=4.7 && <5,+        conduit >=1.3.2 && <1.4,         containers >=0.6.2.1 && <0.7,+        exceptions >=0.10.4 && <0.11,         graphql -any,         hspec >=2.7.1 && <2.8,         hspec-expectations >=0.8.2 && <0.9,@@ -103,5 +110,4 @@         scientific >=0.3.6.2 && <0.4,         text >=1.2.4.0 && <1.3,         transformers >=0.5.6.2 && <0.6,-        unordered-containers >=0.2.10.0 && <0.3,-        vector >=0.12.1.2 && <0.13+        unordered-containers >=0.2.10.0 && <0.3

@@ -1,36 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ -- | This module provides the functions to parse and execute @GraphQL@ queries. module Language.GraphQL     ( graphql     , graphqlSubs     ) where +import Control.Monad.Catch (MonadCatch) import qualified Data.Aeson as Aeson-import Data.HashMap.Strict (HashMap)+import qualified Data.Aeson.Types as Aeson+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Sequence as Seq import Data.Text (Text)-import Language.GraphQL.AST.Document-import Language.GraphQL.AST.Parser+import Language.GraphQL.AST import Language.GraphQL.Error import Language.GraphQL.Execute-import Language.GraphQL.Execute.Coerce+import qualified Language.GraphQL.Validate as Validate import Language.GraphQL.Type.Schema import Text.Megaparsec (parse)  -- | If the text parses correctly as a @GraphQL@ query the query is -- executed using the given 'Schema'.-graphql :: Monad m+graphql :: MonadCatch m     => Schema m -- ^ Resolvers.     -> Text -- ^ Text representing a @GraphQL@ request document.-    -> m Aeson.Value -- ^ Response.-graphql = flip graphqlSubs (mempty :: Aeson.Object)+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.+graphql schema = graphqlSubs schema mempty mempty  -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given -- 'Schema'.-graphqlSubs :: (Monad m, VariableValue a)+graphqlSubs :: MonadCatch m     => Schema m -- ^ Resolvers.-    -> HashMap Name a -- ^ Variable substitution function.+    -> Maybe Text -- ^ Operation name.+    -> Aeson.Object -- ^ Variable substitution function.     -> Text -- ^ Text representing a @GraphQL@ request document.-    -> m Aeson.Value -- ^ Response.-graphqlSubs schema f-    = either parseError (execute schema f)-    . parse document ""+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.+graphqlSubs schema operationName variableValues document' =+    case parse document "" document' of+        Left errorBundle -> pure . formatResponse <$> parseError errorBundle+        Right parsed ->+            case validate parsed of+                Seq.Empty -> fmap formatResponse+                    <$> execute schema operationName variableValues parsed+                errors -> pure $ pure+                    $ HashMap.singleton "errors"+                    $ Aeson.toJSON+                    $ fromValidationError <$> errors+  where+    validate = Validate.document schema Validate.specifiedRules+    formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''+    formatResponse (Response data'' errors') = HashMap.fromList+        [ ("data", data'')+        , ("errors", Aeson.toJSON $ fromError <$> errors')+        ]+    fromError Error{ locations = [], ..} =+        Aeson.object [("message", Aeson.toJSON message)]+    fromError Error{..} = Aeson.object+        [ ("message", Aeson.toJSON message)+        , ("locations", Aeson.listValue fromLocation locations)+        ]+    fromValidationError Validate.Error{..}+        | [] <- path = Aeson.object+            [ ("message", Aeson.toJSON message)+            , ("locations", Aeson.listValue fromLocation locations)+            ]+        | otherwise = Aeson.object+            [ ("message", Aeson.toJSON message)+            , ("locations", Aeson.listValue fromLocation locations)+            , ("path", Aeson.listValue fromPath path)+            ]+    fromPath (Validate.Segment segment) = Aeson.String segment+    fromPath (Validate.Index index) = Aeson.toJSON index+    fromLocation Location{..} = Aeson.object+        [ ("line", Aeson.toJSON line)+        , ("column", Aeson.toJSON column)+        ]

@@ -1,6 +1,8 @@--- | Target AST for Parser.+-- | Target AST for parser. module Language.GraphQL.AST     ( module Language.GraphQL.AST.Document+    , module Language.GraphQL.AST.Parser     ) where  import Language.GraphQL.AST.Document+import Language.GraphQL.AST.Parser

@@ -1,19 +0,0 @@--- | This is the AST meant to be executed.-module Language.GraphQL.AST.Core-    ( Arguments(..)-    ) where--import Data.HashMap.Strict (HashMap)-import Language.GraphQL.AST (Name)-import Language.GraphQL.Type.Definition---- | Argument list.-newtype Arguments = Arguments (HashMap Name Value)-    deriving (Eq, Show)--instance Semigroup Arguments where-    (Arguments x) <> (Arguments y) = Arguments $ x <> y--instance Monoid Arguments where-    mempty = Arguments mempty-

@@ -19,6 +19,7 @@     , FragmentDefinition(..)     , ImplementsInterfaces(..)     , InputValueDefinition(..)+    , Location(..)     , Name     , NamedType     , NonNullType(..)@@ -55,6 +56,12 @@ -- | Name. type Name = Text +-- | Error location, line and column.+data Location = Location+    { line :: Word+    , column :: Word+    } deriving (Eq, Show)+ -- ** Document  -- | GraphQL document.@@ -62,9 +69,9 @@  -- | All kinds of definitions that can occur in a GraphQL document. data Definition-    = ExecutableDefinition ExecutableDefinition-    | TypeSystemDefinition TypeSystemDefinition-    | TypeSystemExtension TypeSystemExtension+    = ExecutableDefinition ExecutableDefinition Location+    | TypeSystemDefinition TypeSystemDefinition Location+    | TypeSystemExtension TypeSystemExtension Location     deriving (Eq, Show)  -- | Top-level definition of a document, either an operation or a fragment.@@ -92,9 +99,7 @@ -- * mutation - a write operation followed by a fetch. -- * subscription - a long-lived request that fetches data in response to -- source events.------ Currently only queries and mutations are supported.-data OperationType = Query | Mutation deriving (Eq, Show)+data OperationType = Query | Mutation | Subscription deriving (Eq, Show)  -- ** Selection Sets 

@@ -1,5 +1,6 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}  -- | This module defines a minifier and a printer for the @GraphQL@ language. module Language.GraphQL.AST.Encoder@@ -49,7 +50,8 @@     | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'   where     encodeDocument = foldr executableDefinition [] defs-    executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc+    executableDefinition (ExecutableDefinition x _) acc =+        definition formatter x : acc     executableDefinition _ acc = acc  -- | Converts a t'ExecutableDefinition' into a string.@@ -65,12 +67,14 @@  -- | Converts a 'OperationDefinition into a string. operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text-operationDefinition formatter (SelectionSet sels)-    = selectionSet formatter sels-operationDefinition formatter (OperationDefinition Query name vars dirs sels)-    = "query " <> node formatter name vars dirs sels-operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)-    = "mutation " <> node formatter name vars dirs sels+operationDefinition formatter = \case+    SelectionSet sels -> selectionSet formatter sels+    OperationDefinition Query name vars dirs sels ->+        "query " <> node formatter name vars dirs sels+    OperationDefinition Mutation name vars dirs sels ->+        "mutation " <> node formatter name vars dirs sels+    OperationDefinition Subscription name vars dirs sels ->+        "subscription " <> node formatter name vars dirs sels  -- | Converts a Query or Mutation into a string. node :: Formatter ->@@ -254,19 +258,20 @@           char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')        tripleQuote = Builder.fromText "\"\"\""-      start = tripleQuote <> Builder.singleton '\n'-      end = Builder.fromLazyText (indent indentation) <> tripleQuote+      newline = Builder.singleton '\n'        strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace       lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string)       encoded [] = oneLine string       encoded [_] = oneLine string-      encoded lines'' = start <> transformLines lines'' <> end-      transformLines = foldr ((\line acc -> line <> Builder.singleton '\n' <> acc) . transformLine) mempty-      transformLine line =-        if Lazy.Text.null (Builder.toLazyText line)-        then line-        else Builder.fromLazyText (indent (indentation + 1)) <> line+      encoded lines'' = tripleQuote <> newline+        <> transformLines lines''+        <> Builder.fromLazyText (indent indentation) <> tripleQuote+      transformLines = foldr transformLine mempty+      transformLine "" acc = newline <> acc+      transformLine line' acc+            = Builder.fromLazyText (indent (indentation + 1))+            <> line' <> newline <> acc  escape :: Char -> Builder escape char'

@@ -168,11 +168,11 @@  -- | Parser for integers. integer :: Integral a => Parser a-integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal+integer = Lexer.signed (pure ()) (lexeme Lexer.decimal) <?> "IntValue"  -- | Parser for floating-point numbers. float :: Parser Double-float = Lexer.signed (pure ()) $ lexeme Lexer.float+float = Lexer.signed (pure ()) (lexeme Lexer.float) <?> "FloatValue"  -- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/). name :: Parser T.Text

@@ -1,12 +1,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  -- | @GraphQL@ document parser. module Language.GraphQL.AST.Parser     ( document     ) where -import Control.Applicative (Alternative(..), optional)+import Control.Applicative (Alternative(..), liftA2, optional) import Control.Applicative.Combinators (sepBy1) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..))@@ -19,20 +20,48 @@     ) import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer-import Text.Megaparsec (lookAhead, option, try, (<?>))+import Text.Megaparsec+    ( SourcePos(..)+    , getSourcePos+    , lookAhead+    , option+    , try+    , unPos+    , (<?>)+    )  -- | Parser for the GraphQL documents. document :: Parser Document document = unicodeBOM-    >> spaceConsumer-    >> lexeme (NonEmpty.some definition)+    *> spaceConsumer+    *> lexeme (NonEmpty.some definition)  definition :: Parser Definition-definition = ExecutableDefinition <$> executableDefinition-    <|> TypeSystemDefinition <$> typeSystemDefinition-    <|> TypeSystemExtension <$> typeSystemExtension+definition = executableDefinition'+    <|> typeSystemDefinition'+    <|> typeSystemExtension'     <?> "Definition"+  where+    executableDefinition' = do+        location <- getLocation+        definition' <- executableDefinition+        pure $ ExecutableDefinition definition' location+    typeSystemDefinition' = do+        location <- getLocation+        definition' <- typeSystemDefinition+        pure $ TypeSystemDefinition definition' location+    typeSystemExtension' = do+        location <- getLocation+        definition' <- typeSystemExtension+        pure $ TypeSystemExtension definition' location +getLocation :: Parser Location+getLocation = fromSourcePosition <$> getSourcePos+  where+    fromSourcePosition SourcePos{..} =+        Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)+    wordFromPosition = fromIntegral . unPos+ executableDefinition :: Parser ExecutableDefinition executableDefinition = DefinitionOperation <$> operationDefinition     <|> DefinitionFragment  <$> fragmentDefinition@@ -40,19 +69,22 @@  typeSystemDefinition :: Parser TypeSystemDefinition typeSystemDefinition = schemaDefinition-    <|> TypeDefinition <$> typeDefinition-    <|> directiveDefinition+    <|> typeSystemDefinitionWithDescription     <?> "TypeSystemDefinition"+  where+    typeSystemDefinitionWithDescription = description+        >>= liftA2 (<|>) typeDefinition' directiveDefinition+    typeDefinition' description' = TypeDefinition+        <$> typeDefinition description'  typeSystemExtension :: Parser TypeSystemExtension typeSystemExtension = SchemaExtension <$> schemaExtension     <|> TypeExtension <$> typeExtension     <?> "TypeSystemExtension" -directiveDefinition :: Parser TypeSystemDefinition-directiveDefinition = DirectiveDefinition-    <$> description-    <* symbol "directive"+directiveDefinition :: Description -> Parser TypeSystemDefinition+directiveDefinition description' = DirectiveDefinition description'+    <$ symbol "directive"     <* at     <*> name     <*> argumentsDefinition@@ -63,11 +95,13 @@ directiveLocations :: Parser (NonEmpty DirectiveLocation) directiveLocations = optional pipe     *> directiveLocation `NonEmpty.sepBy1` pipe+    <?> "DirectiveLocations"  directiveLocation :: Parser DirectiveLocation directiveLocation     = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation     <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation+    <?> "DirectiveLocation"  executableDirectiveLocation :: Parser ExecutableDirectiveLocation executableDirectiveLocation = Directive.Query <$ symbol "QUERY"@@ -77,6 +111,7 @@     <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"     <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"     <|> Directive.InlineFragment <$ "INLINE_FRAGMENT"+    <?> "ExecutableDirectiveLocation"  typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"@@ -90,14 +125,15 @@     <|> Directive.EnumValue <$ symbol "ENUM_VALUE"     <|> Directive.InputObject <$ symbol "INPUT_OBJECT"     <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"+    <?> "TypeSystemDirectiveLocation" -typeDefinition :: Parser TypeDefinition-typeDefinition = scalarTypeDefinition-    <|> objectTypeDefinition-    <|> interfaceTypeDefinition-    <|> unionTypeDefinition-    <|> enumTypeDefinition-    <|> inputObjectTypeDefinition+typeDefinition :: Description -> Parser TypeDefinition+typeDefinition description' = scalarTypeDefinition description'+    <|> objectTypeDefinition description'+    <|> interfaceTypeDefinition description'+    <|> unionTypeDefinition description'+    <|> enumTypeDefinition description'+    <|> inputObjectTypeDefinition description'     <?> "TypeDefinition"  typeExtension :: Parser TypeExtension@@ -109,10 +145,9 @@     <|> inputObjectTypeExtension     <?> "TypeExtension" -scalarTypeDefinition :: Parser TypeDefinition-scalarTypeDefinition = ScalarTypeDefinition-    <$> description-    <* symbol "scalar"+scalarTypeDefinition :: Description -> Parser TypeDefinition+scalarTypeDefinition description' = ScalarTypeDefinition description'+    <$ symbol "scalar"     <*> name     <*> directives     <?> "ScalarTypeDefinition"@@ -121,10 +156,9 @@ scalarTypeExtension = extend "scalar" "ScalarTypeExtension"     $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] -objectTypeDefinition :: Parser TypeDefinition-objectTypeDefinition = ObjectTypeDefinition-    <$> description-    <* symbol "type"+objectTypeDefinition :: Description -> Parser TypeDefinition+objectTypeDefinition description' = ObjectTypeDefinition description'+    <$ symbol "type"     <*> name     <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)     <*> directives@@ -153,13 +187,12 @@  description :: Parser Description description = Description-    <$> optional (string <|> blockString)+    <$> optional stringValue     <?> "Description" -unionTypeDefinition :: Parser TypeDefinition-unionTypeDefinition = UnionTypeDefinition-    <$> description-    <* symbol "union"+unionTypeDefinition :: Description -> Parser TypeDefinition+unionTypeDefinition description' = UnionTypeDefinition description'+    <$ symbol "union"     <*> name     <*> directives     <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)@@ -187,10 +220,9 @@     <*> name `sepBy'` pipe     <?> "UnionMemberTypes" -interfaceTypeDefinition :: Parser TypeDefinition-interfaceTypeDefinition = InterfaceTypeDefinition-    <$> description-    <* symbol "interface"+interfaceTypeDefinition :: Description -> Parser TypeDefinition+interfaceTypeDefinition description' = InterfaceTypeDefinition description'+    <$ symbol "interface"     <*> name     <*> directives     <*> braces (many fieldDefinition)@@ -208,10 +240,9 @@         <$> name         <*> NonEmpty.some directive -enumTypeDefinition :: Parser TypeDefinition-enumTypeDefinition = EnumTypeDefinition-    <$> description-    <* symbol "enum"+enumTypeDefinition :: Description -> Parser TypeDefinition+enumTypeDefinition description' = EnumTypeDefinition description'+    <$ symbol "enum"     <*> name     <*> directives     <*> listOptIn braces enumValueDefinition@@ -229,10 +260,9 @@         <$> name         <*> NonEmpty.some directive -inputObjectTypeDefinition :: Parser TypeDefinition-inputObjectTypeDefinition = InputObjectTypeDefinition-    <$> description-    <* symbol "input"+inputObjectTypeDefinition :: Description -> Parser TypeDefinition+inputObjectTypeDefinition description' = InputObjectTypeDefinition description'+    <$ symbol "input"     <*> name     <*> directives     <*> listOptIn braces inputValueDefinition@@ -321,7 +351,7 @@ operationDefinition :: Parser OperationDefinition operationDefinition = SelectionSet <$> selectionSet     <|> operationDefinition'-    <?> "operationDefinition error"+    <?> "OperationDefinition"   where     operationDefinition'         = OperationDefinition <$> operationType@@ -333,23 +363,20 @@ operationType :: Parser OperationType operationType = Query <$ symbol "query"     <|> Mutation <$ symbol "mutation"-    -- <?> Keep default error message---- * SelectionSet+    <|> Subscription <$ symbol "subscription"+    <?> "OperationType"  selectionSet :: Parser SelectionSet-selectionSet = braces $ NonEmpty.some selection+selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"  selectionSetOpt :: Parser SelectionSetOpt-selectionSetOpt = listOptIn braces selection+selectionSetOpt = listOptIn braces selection <?> "SelectionSet"  selection :: Parser Selection selection = field     <|> try fragmentSpread     <|> inlineFragment-    <?> "selection error!"---- * Field+    <?> "Selection"  field :: Parser Selection field = Field@@ -358,25 +385,23 @@     <*> arguments     <*> directives     <*> selectionSetOpt+    <?> "Field"  alias :: Parser Alias-alias = try $ name <* colon---- * Arguments+alias = try (name <* colon) <?> "Alias"  arguments :: Parser [Argument]-arguments = listOptIn parens argument+arguments = listOptIn parens argument <?> "Arguments"  argument :: Parser Argument-argument = Argument <$> name <* colon <*> value---- * Fragments+argument = Argument <$> name <* colon <*> value <?> "Argument"  fragmentSpread :: Parser Selection fragmentSpread = FragmentSpread     <$ spread     <*> fragmentName     <*> directives+    <?> "FragmentSpread"  inlineFragment :: Parser Selection inlineFragment = InlineFragment@@ -384,62 +409,74 @@     <*> optional typeCondition     <*> directives     <*> selectionSet+    <?> "InlineFragment"  fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition-                 <$  symbol "fragment"-                 <*> name-                 <*> typeCondition-                 <*> directives-                 <*> selectionSet+    <$  symbol "fragment"+    <*> name+    <*> typeCondition+    <*> directives+    <*> selectionSet+    <?> "FragmentDefinition"  fragmentName :: Parser Name-fragmentName = but (symbol "on") *> name+fragmentName = but (symbol "on") *> name <?> "FragmentName"  typeCondition :: Parser TypeCondition-typeCondition = symbol "on" *> name---- * Input Values+typeCondition = symbol "on" *> name <?> "TypeCondition"  value :: Parser Value value = Variable <$> variable     <|> Float <$> try float     <|> Int <$> integer     <|> Boolean <$> booleanValue-    <|> Null <$  symbol "null"-    <|> String <$> blockString-    <|> String <$> string+    <|> Null <$  nullValue+    <|> String <$> stringValue     <|> Enum <$> try enumValue     <|> List <$> brackets (some value)     <|> Object <$> braces (some $ objectField value)-    <?> "value error!"+    <?> "Value"  constValue :: Parser ConstValue constValue = ConstFloat <$> try float     <|> ConstInt <$> integer     <|> ConstBoolean <$> booleanValue-    <|> ConstNull <$  symbol "null"-    <|> ConstString <$> blockString-    <|> ConstString <$> string+    <|> ConstNull <$ nullValue+    <|> ConstString <$> stringValue     <|> ConstEnum <$> try enumValue     <|> ConstList <$> brackets (some constValue)     <|> ConstObject <$> braces (some $ objectField constValue)-    <?> "value error!"+    <?> "Value"  booleanValue :: Parser Bool booleanValue = True  <$ symbol "true"     <|> False <$ symbol "false"+    <?> "BooleanValue"  enumValue :: Parser Name-enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name+enumValue = but (symbol "true")+    *> but (symbol "false")+    *> but (symbol "null")+    *> name+    <?> "EnumValue" -objectField :: Parser a -> Parser (ObjectField a)-objectField valueParser = ObjectField <$> name <* colon <*> valueParser+stringValue :: Parser Text+stringValue = blockString <|> string <?> "StringValue" --- * Variables+nullValue :: Parser Text+nullValue = symbol "null" <?> "NullValue" +objectField :: Parser a -> Parser (ObjectField a)+objectField valueParser = ObjectField+    <$> name+    <* colon+    <*> valueParser+    <?> "ObjectField"+ variableDefinitions :: Parser [VariableDefinition] variableDefinitions = listOptIn parens variableDefinition+    <?> "VariableDefinitions"  variableDefinition :: Parser VariableDefinition variableDefinition = VariableDefinition@@ -450,13 +487,11 @@     <?> "VariableDefinition"  variable :: Parser Name-variable = dollar *> name+variable = dollar *> name <?> "Variable"  defaultValue :: Parser (Maybe ConstValue) defaultValue = optional (equals *> constValue) <?> "DefaultValue" --- * Input Types- type' :: Parser Type type' = try (TypeNonNull <$> nonNullType)     <|> TypeList <$> brackets type'@@ -465,21 +500,18 @@  nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> name <* bang-          <|> NonNullTypeList  <$> brackets type'  <* bang-          <?> "nonNullType error!"---- * Directives+    <|> NonNullTypeList  <$> brackets type'  <* bang+    <?> "NonNullType"  directives :: Parser [Directive]-directives = many directive+directives = many directive <?> "Directives"  directive :: Parser Directive directive = Directive     <$  at     <*> name     <*> arguments---- * Internal+    <?> "Directive"  listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn surround = option [] . surround . some

@@ -1,3 +1,5 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -5,20 +7,29 @@ module Language.GraphQL.Error     ( parseError     , CollectErrsT+    , Error(..)     , Resolution(..)+    , ResolverException(..)+    , Response(..)+    , ResponseEventStream     , addErr     , addErrMsg     , runCollectErrs     , singleError     ) where +import Conduit+import Control.Exception (Exception(..)) import Control.Monad.Trans.State (StateT, modify, runStateT)-import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap)+import Data.Sequence (Seq(..), (|>))+import qualified Data.Sequence as Seq import Data.Text (Text)-import Data.Void (Void)-import Language.GraphQL.AST.Document (Name)+import qualified Data.Text as Text+import Language.GraphQL.AST (Location(..), Name)+import Language.GraphQL.Execute.Coerce import Language.GraphQL.Type.Schema+import Prelude hiding (null) import Text.Megaparsec     ( ParseErrorBundle(..)     , PosState(..)@@ -31,59 +42,85 @@  -- | Executor context. data Resolution m = Resolution-    { errors :: [Aeson.Value]+    { errors :: Seq Error     , types :: HashMap Name (Type m)     }  -- | Wraps a parse error into a list of errors.-parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value+parseError :: (Applicative f, Serialize a)+    => ParseErrorBundle Text Void+    -> f (Response a) parseError ParseErrorBundle{..}  =-    pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]+    pure $ Response null $ fst+        $ foldl go (Seq.empty, bundlePosState) bundleErrors   where-    errorObject s SourcePos{..} = Aeson.object-        [ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)-        , ("line", Aeson.toJSON $ unPos sourceLine)-        , ("column", Aeson.toJSON $ unPos sourceColumn)-        ]+    errorObject s SourcePos{..} = Error+        { message = Text.pack $ init $ parseErrorTextPretty s+        , locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]+        }+    unPos' = fromIntegral . unPos     go (result, state) x =         let (_, newState) = reachOffset (errorOffset x) state             sourcePosition = pstateSourcePos newState-         in (errorObject x sourcePosition : result, newState)+         in (result |> errorObject x sourcePosition, newState)  -- | A wrapper to pass error messages around. type CollectErrsT m = StateT (Resolution m) m  -- | Adds an error to the list of errors.-addErr :: Monad m => Aeson.Value -> CollectErrsT m ()+addErr :: Monad m => Error -> CollectErrsT m () addErr v = modify appender   where-    appender resolution@Resolution{..} = resolution{ errors = v : errors }+    appender :: Monad m => Resolution m -> Resolution m+    appender resolution@Resolution{..} = resolution{ errors = errors |> v } -makeErrorMessage :: Text -> Aeson.Value-makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]+makeErrorMessage :: Text -> Error+makeErrorMessage s = Error s []  -- | Constructs a response object containing only the error with the given---   message.-singleError :: Text -> Aeson.Value-singleError message = Aeson.object-    [ ("errors", Aeson.toJSON [makeErrorMessage message])-    ]+-- message.+singleError :: Serialize a => Text -> Response a+singleError message = Response null $ Seq.singleton $ makeErrorMessage message  -- | Convenience function for just wrapping an error message.-addErrMsg :: Monad m => Text -> CollectErrsT m ()-addErrMsg = addErr . makeErrorMessage+addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a+addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null +-- | @GraphQL@ error.+data Error = Error+    { message :: Text+    , locations :: [Location]+    } deriving (Eq, Show)++-- | The server\'s response describes the result of executing the requested+-- operation if successful, and describes any errors encountered during the+-- request.+data Response a = Response+    { data' :: a+    , errors :: Seq Error+    } deriving (Eq, Show)++-- | Each event in the underlying Source Stream triggers execution of the+-- subscription selection set. The results of the execution generate a Response+-- Stream.+type ResponseEventStream m a = ConduitT () (Response a) m ()++-- | Only exceptions that inherit from 'ResolverException' a cought by the+-- executor.+data ResolverException = forall e. Exception e => ResolverException e++instance Show ResolverException where+    show (ResolverException e) = show e++instance Exception ResolverException+ -- | Runs the given query computation, but collects the errors into an error---   list, which is then sent back with the data.-runCollectErrs :: Monad m+-- list, which is then sent back with the data.+runCollectErrs :: (Monad m, Serialize a)     => HashMap Name (Type m)-    -> CollectErrsT m Aeson.Value-    -> m Aeson.Value+    -> CollectErrsT m a+    -> m (Response a) runCollectErrs types' res = do-    (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }-    if null errors-       then return $ Aeson.object [("data", dat)]-       else return $ Aeson.object-           [ ("data", dat)-           , ("errors", Aeson.toJSON $ reverse errors)-           ]+    (dat, Resolution{..}) <- runStateT res+        $ Resolution{ errors = Seq.empty, types = types' }+    pure $ Response dat errors

@@ -1,71 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute     ( execute-    , executeWithName+    , module Language.GraphQL.Execute.Coerce     ) where -import qualified Data.Aeson as Aeson+import Control.Monad.Catch (MonadCatch) import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap import Data.Sequence (Seq(..)) import Data.Text (Text) import Language.GraphQL.AST.Document (Document, Name) import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Execution import qualified Language.GraphQL.Execute.Transform as Transform+import qualified Language.GraphQL.Execute.Subscribe as Subscribe import Language.GraphQL.Error import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema  -- | The substitution is applied to the document, and the resolvers are applied--- to the resulting fields.------ Returns the result of the query against the schema wrapped in a /data/--- field, or errors wrapped in an /errors/ field.-execute :: (Monad m, VariableValue a)-    => Schema m -- ^ Resolvers.-    -> HashMap.HashMap Name a -- ^ Variable substitution function.-    -> Document -- @GraphQL@ document.-    -> m Aeson.Value-execute schema = executeRequest schema Nothing---- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document -- defines multiple root operations. -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field.-executeWithName :: (Monad m, VariableValue a)-    => Schema m -- ^ Resolvers-    -> Text -- ^ Operation name.-    -> HashMap.HashMap Name a -- ^ Variable substitution function.-    -> Document -- ^ @GraphQL@ Document.-    -> m Aeson.Value-executeWithName schema operationName =-    executeRequest schema (Just operationName)--executeRequest :: (Monad m, VariableValue a)-    => Schema m-    -> Maybe Text-    -> HashMap.HashMap Name a-    -> Document-    -> m Aeson.Value-executeRequest schema operationName subs document =+execute :: (MonadCatch m, VariableValue a, Serialize b)+    => Schema m -- ^ Resolvers.+    -> Maybe Text -- ^ Operation name.+    -> HashMap Name a -- ^ Variable substitution function.+    -> Document -- @GraphQL@ document.+    -> m (Either (ResponseEventStream m b) (Response b))+execute schema operationName subs document =     case Transform.document schema operationName subs document of-        Left queryError -> pure $ singleError $ Transform.queryError queryError-        Right (Transform.Document types' rootObjectType operation)-          | (Transform.Query _ fields) <- operation ->-              executeOperation types' rootObjectType fields-          | (Transform.Mutation _ fields) <- operation ->-              executeOperation types' rootObjectType fields+        Left queryError -> pure+            $ Right+            $ singleError+            $ Transform.queryError queryError+        Right transformed -> executeRequest transformed +executeRequest :: (MonadCatch m, Serialize a)+    => Transform.Document m+    -> m (Either (ResponseEventStream m a) (Response a))+executeRequest (Transform.Document types' rootObjectType operation)+    | (Transform.Query _ fields) <- operation =+        Right <$> executeOperation types' rootObjectType fields+    | (Transform.Mutation _ fields) <- operation =+        Right <$> executeOperation types' rootObjectType fields+    | (Transform.Subscription _ fields) <- operation+        = either (Right . singleError) Left+        <$> Subscribe.subscribe types' rootObjectType fields+ -- This is actually executeMutation, but we don't distinguish between queries -- and mutations yet.-executeOperation :: Monad m+executeOperation :: (MonadCatch m, Serialize a)     => HashMap Name (Type m)     -> Out.ObjectType m     -> Seq (Transform.Selection m)-    -> m Aeson.Value+    -> m (Response a) executeOperation types' objectType fields =     runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields

@@ -3,11 +3,13 @@ {-# LANGUAGE ViewPatterns #-}  module Language.GraphQL.Execute.Execution-    ( executeSelectionSet+    ( coerceArgumentValues+    , collectFields+    , executeSelectionSet     ) where +import Control.Monad.Catch (Exception(..), MonadCatch(..)) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State (gets) import Data.List.NonEmpty (NonEmpty(..))@@ -17,28 +19,35 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Sequence (Seq(..))-import Data.Text (Text)+import qualified Data.Text as Text import Language.GraphQL.AST (Name)-import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Execute.Coerce import qualified Language.GraphQL.Execute.Transform as Transform-import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Schema import Prelude hiding (null) -resolveFieldValue :: Monad m+resolveFieldValue :: MonadCatch m     => Type.Value     -> Type.Subs-    -> ActionT m a-    -> m (Either Text a)-resolveFieldValue result args =-    flip runReaderT (Context {arguments = Arguments args, values = result})-    . runExceptT-    . runActionT+    -> Type.Resolve m+    -> CollectErrsT m Type.Value+resolveFieldValue result args resolver =+    catch (lift $ runReaderT resolver context) handleFieldError+  where+    handleFieldError :: MonadCatch m+        => ResolverException+        -> CollectErrsT m Type.Value+    handleFieldError e =+        addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null+    context = Type.Context+        { Type.arguments = Type.Arguments args+        , Type.values = result+        }  collectFields :: Monad m     => Out.ObjectType m@@ -98,23 +107,27 @@   where     go unionMemberType acc = acc || objectType == unionMemberType -executeField :: (Monad m, Serialize a)+executeField :: (MonadCatch m, Serialize a)     => Out.Resolver m     -> Type.Value     -> NonEmpty (Transform.Field m)     -> CollectErrsT m a-executeField (Out.Resolver fieldDefinition resolver) prev fields = do-    let Out.Field _ fieldType argumentDefinitions = fieldDefinition-    let (Transform.Field _ _ arguments' _ :| []) = fields-    case coerceArgumentValues argumentDefinitions arguments' of-        Nothing -> errmsg "Argument coercing failed."-        Just argumentValues -> do-            answer <- lift $ resolveFieldValue prev argumentValues resolver-            case answer of-                Right result -> completeValue fieldType fields result-                Left errorMessage -> errmsg errorMessage+executeField fieldResolver prev fields+    | Out.ValueResolver fieldDefinition resolver <- fieldResolver =+        executeField' fieldDefinition resolver+    | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =+        executeField' fieldDefinition resolver+  where+    executeField' fieldDefinition resolver = do+        let Out.Field _ fieldType argumentDefinitions = fieldDefinition+        let (Transform.Field _ _ arguments' _ :| []) = fields+        case coerceArgumentValues argumentDefinitions arguments' of+            Nothing -> addErrMsg "Argument coercing failed."+            Just argumentValues -> do+                answer <- resolveFieldValue prev argumentValues resolver+                completeValue fieldType fields answer -completeValue :: (Monad m, Serialize a)+completeValue :: (MonadCatch m, Serialize a)     => Out.Type m     -> NonEmpty (Transform.Field m)     -> Type.Value@@ -135,7 +148,7 @@     let Type.EnumType _ _ enumMembers = enumType      in if HashMap.member enum enumMembers         then coerceResult outputType $ Enum enum-        else errmsg "Value completion failed."+        else addErrMsg "Value completion failed." completeValue (Out.ObjectBaseType objectType) fields result =     executeSelectionSet result objectType $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result@@ -145,7 +158,7 @@         case concreteType of             Just objectType -> executeSelectionSet result objectType                 $ mergeSelectionSets fields-            Nothing -> errmsg "Value completion failed."+            Nothing -> addErrMsg "Value completion failed." completeValue (Out.UnionBaseType unionType) fields result     | Type.Object objectMap <- result = do         let abstractType = AbstractUnionType unionType@@ -153,30 +166,29 @@         case concreteType of             Just objectType -> executeSelectionSet result objectType                 $ mergeSelectionSets fields-            Nothing -> errmsg "Value completion failed."-completeValue _ _ _ = errmsg "Value completion failed."+            Nothing -> addErrMsg "Value completion failed."+completeValue _ _ _ = addErrMsg "Value completion failed." -mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)+mergeSelectionSets :: MonadCatch m+    => NonEmpty (Transform.Field m)+    -> Seq (Transform.Selection m) mergeSelectionSets = foldr forEach mempty   where     forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =         selectionSet <> fieldSelectionSet -errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a-errmsg errorMessage = addErrMsg errorMessage >> pure null--coerceResult :: (Monad m, Serialize a)+coerceResult :: (MonadCatch m, Serialize a)     => Out.Type m     -> Output a     -> CollectErrsT m a coerceResult outputType result     | Just serialized <- serialize outputType result = pure serialized-    | otherwise = errmsg "Result coercion failed."+    | otherwise = addErrMsg "Result coercion failed."  -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies -- each field to each 'Transform.Selection'. Resolves into a value containing -- the resolved 'Transform.Selection', or a null value and error information.-executeSelectionSet :: (Monad m, Serialize a)+executeSelectionSet :: (MonadCatch m, Serialize a)     => Type.Value     -> Out.ObjectType m     -> Seq (Transform.Selection m)

@@ -0,0 +1,97 @@+{- 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 ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.Execute.Subscribe+    ( subscribe+    ) where++import Conduit+import Control.Monad.Catch (Exception(..), MonadCatch(..))+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map.Strict as Map+import qualified Data.List.NonEmpty as NonEmpty+import Data.Sequence (Seq(..))+import Data.Text (Text)+import qualified Data.Text as Text+import Language.GraphQL.AST (Name)+import Language.GraphQL.Execute.Coerce+import Language.GraphQL.Execute.Execution+import qualified Language.GraphQL.Execute.Transform as Transform+import Language.GraphQL.Error+import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.Type as Type+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Schema++-- This is actually executeMutation, but we don't distinguish between queries+-- and mutations yet.+subscribe :: (MonadCatch m, Serialize a)+    => HashMap Name (Type m)+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> m (Either Text (ResponseEventStream m a))+subscribe types' objectType fields = do+    sourceStream <- createSourceEventStream types' objectType fields+    traverse (mapSourceToResponseEvent types' objectType fields) sourceStream++mapSourceToResponseEvent :: (MonadCatch m, Serialize a)+    => HashMap Name (Type m)+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> Out.SourceEventStream m+    -> m (ResponseEventStream m a)+mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure+    $ sourceStream+    .| mapMC (executeSubscriptionEvent types' subscriptionType fields)++createSourceEventStream :: MonadCatch m+    => HashMap Name (Type m)+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> m (Either Text (Out.SourceEventStream m))+createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields+    | [fieldGroup] <- Map.elems groupedFieldSet+    , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup+    , resolverT <- fieldTypes HashMap.! fieldName+    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT+    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =+        case coerceArgumentValues argumentDefinitions arguments' of+            Nothing -> pure $ Left "Argument coercion failed."+            Just argumentValues ->+                resolveFieldEventStream Type.Null argumentValues resolver+    | otherwise = pure $ Left "Subscription contains more than one field."+  where+    groupedFieldSet = collectFields subscriptionType fields++resolveFieldEventStream :: MonadCatch m+    => Type.Value+    -> Type.Subs+    -> Out.Subscribe m+    -> m (Either Text (Out.SourceEventStream m))+resolveFieldEventStream result args resolver =+    catch (Right <$> runReaderT resolver context) handleEventStreamError+  where+    handleEventStreamError :: MonadCatch m+        => ResolverException+        -> m (Either Text (Out.SourceEventStream m))+    handleEventStreamError = pure . Left . Text.pack . displayException+    context = Type.Context+        { Type.arguments = Type.Arguments args+        , Type.values = result+        }++-- This is actually executeMutation, but we don't distinguish between queries+-- and mutations yet.+executeSubscriptionEvent :: (MonadCatch m, Serialize a)+    => HashMap Name (Type m)+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> Definition.Value+    -> m (Response a)+executeSubscriptionEvent types' objectType fields initialValue =+    runCollectErrs types' $ executeSelectionSet initialValue objectType fields

@@ -44,12 +44,11 @@ import qualified Data.Text as Text import qualified Language.GraphQL.AST as Full import Language.GraphQL.AST (Name)-import Language.GraphQL.AST.Core import qualified Language.GraphQL.Execute.Coerce as Coerce-import Language.GraphQL.Type.Directive (Directive(..))-import qualified Language.GraphQL.Type.Directive as Directive+import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In+import Language.GraphQL.Type.Internal import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema @@ -78,6 +77,7 @@ data Operation m     = Query (Maybe Text) (Seq (Selection m))     | Mutation (Maybe Text) (Seq (Selection m))+    | Subscription (Maybe Text) (Seq (Selection m))  -- | Single GraphQL field. data Field m = Field@@ -239,6 +239,10 @@             | Just mutationType <- mutation schema ->                 pure $ Document referencedTypes mutationType                     $ operation chosenOperation replacement+        OperationDefinition Full.Subscription _ _ _ _+            | Just subscriptionType <- subscription schema ->+                pure $ Document referencedTypes subscriptionType+                    $ operation chosenOperation replacement         _ -> Left UnsupportedRootOperation  defragment@@ -251,10 +255,10 @@      in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations   where     defragment' definition (operations, fragments')-        | (Full.ExecutableDefinition executable) <- definition+        | (Full.ExecutableDefinition executable _) <- definition         , (Full.DefinitionOperation operation') <- executable =             (transform operation' : operations, fragments')-        | (Full.ExecutableDefinition executable) <- definition+        | (Full.ExecutableDefinition executable _) <- definition         , (Full.DefinitionFragment fragment) <- executable         , (Full.FragmentDefinition name _ _ _) <- fragment =             (operations, HashMap.insert name fragment fragments')@@ -276,6 +280,8 @@         Query name <$> appendSelection sels     transform (OperationDefinition Full.Mutation name _ _ sels) =         Mutation name <$> appendSelection sels+    transform (OperationDefinition Full.Subscription name _ _ sels) =+        Subscription name <$> appendSelection sels  -- * Selection @@ -286,7 +292,7 @@     maybe (Left mempty) (Right . SelectionField) <$> do         fieldArguments <- foldM go HashMap.empty arguments'         fieldSelections <- appendSelection selections-        fieldDirectives <- Directive.selection <$> directives directives'+        fieldDirectives <- Definition.selection <$> directives directives'         let field' = Field alias name fieldArguments fieldSelections         pure $ field' <$ fieldDirectives   where@@ -295,7 +301,7 @@  selection (Full.FragmentSpread name directives') =     maybe (Left mempty) (Right . SelectionFragment) <$> do-        spreadDirectives <- Directive.selection <$> directives directives'+        spreadDirectives <- Definition.selection <$> directives directives'         fragments' <- gets fragments          fragmentDefinitions' <- gets fragmentDefinitions@@ -309,7 +315,7 @@                         _ -> lift $ pure  Nothing                 | otherwise -> lift $ pure  Nothing selection (Full.InlineFragment type' directives' selections) = do-    fragmentDirectives <- Directive.selection <$> directives directives'+    fragmentDirectives <- Definition.selection <$> directives directives'     case fragmentDirectives of         Nothing -> pure $ Left mempty         _ -> do@@ -337,11 +343,11 @@     append acc (Left list) = list >< acc     append acc (Right one) = one <| acc -directives :: [Full.Directive] ->  State (Replacement m) [Directive]+directives :: [Full.Directive] ->  State (Replacement m) [Definition.Directive] directives = traverse directive   where     directive (Full.Directive directiveName directiveArguments)-        = Directive directiveName . Arguments+        = Definition.Directive directiveName . Type.Arguments         <$> foldM go HashMap.empty directiveArguments     go arguments (Full.Argument name value') = do         substitutedValue <- value value'

@@ -1,67 +0,0 @@--- | Monad transformer stack used by the @GraphQL@ resolvers.-module Language.GraphQL.Trans-    ( argument-    , ActionT(..)-    , Context(..)-    ) where--import Control.Applicative (Alternative(..))-import Control.Monad (MonadPlus(..))-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Except (ExceptT)-import Control.Monad.Trans.Reader (ReaderT, asks)-import qualified Data.HashMap.Strict as HashMap-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Language.GraphQL.AST (Name)-import Language.GraphQL.AST.Core-import Language.GraphQL.Type.Definition-import Prelude hiding (lookup)---- | Resolution context holds resolver arguments.-data Context = Context-    { arguments :: Arguments-    , values :: Value-    }---- | Monad transformer stack used by the resolvers to provide error handling---   and resolution context (resolver arguments).-newtype ActionT m a = ActionT-    { runActionT :: ExceptT Text (ReaderT Context m) a-    }--instance Functor m => Functor (ActionT m) where-    fmap f = ActionT . fmap f . runActionT--instance Monad m => Applicative (ActionT m) where-    pure = ActionT . pure-    (ActionT f) <*> (ActionT x) = ActionT $ f <*> x--instance Monad m => Monad (ActionT m) where-    return = pure-    (ActionT action) >>= f = ActionT $ action >>= runActionT . f--instance MonadTrans ActionT where-    lift = ActionT . lift . lift--instance MonadIO m => MonadIO (ActionT m) where-    liftIO = lift . liftIO--instance Monad m => Alternative (ActionT m) where-    empty = ActionT empty-    (ActionT x) <|> (ActionT y) = ActionT $ x <|> y--instance Monad m => MonadPlus (ActionT m) where-    mzero = empty-    mplus = (<|>)---- | Retrieves an argument by its name. If the argument with this name couldn't---   be found, returns 'Null' (i.e. the argument is assumed to---   be optional then).-argument :: Monad m => Name -> ActionT m Value-argument argumentName = do-    argumentValue <- ActionT $ lift $ asks $ lookup . arguments-    pure $ fromMaybe Null argumentValue-  where-    lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap

@@ -1,11 +1,21 @@+{- 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/. -}+ -- | Reexports non-conflicting type system and schema definitions. module Language.GraphQL.Type     ( In.InputField(..)     , In.InputObjectType(..)+    , Out.Context(..)     , Out.Field(..)     , Out.InterfaceType(..)     , Out.ObjectType(..)+    , Out.Resolve+    , Out.Resolver(..)+    , Out.SourceEventStream+    , Out.Subscribe     , Out.UnionType(..)+    , Out.argument     , module Language.GraphQL.Type.Definition     , module Language.GraphQL.Type.Schema     ) where

@@ -2,7 +2,9 @@  -- | Types that can be used as both input and output types. module Language.GraphQL.Type.Definition-    ( EnumType(..)+    ( Arguments(..)+    , Directive(..)+    , EnumType(..)     , EnumValue(..)     , ScalarType(..)     , Subs@@ -11,14 +13,16 @@     , float     , id     , int+    , selection     , string     ) where  import Data.Int (Int32) import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.String (IsString(..)) import Data.Text (Text)-import Language.GraphQL.AST.Document (Name)+import Language.GraphQL.AST (Name) import Prelude hiding (id)  -- | Represents accordingly typed GraphQL values.@@ -40,6 +44,16 @@ -- and the value is the variable value. type Subs = HashMap Name Value +-- | Argument list.+newtype Arguments = Arguments (HashMap Name Value)+    deriving (Eq, Show)++instance Semigroup Arguments where+    (Arguments x) <> (Arguments y) = Arguments $ x <> y++instance Monoid Arguments where+    mempty = Arguments mempty+ -- | Scalar type definition. -- -- The leaf values of any request and input values to arguments are Scalars (or@@ -113,3 +127,49 @@         \JSON response as a String; however, it is not intended to be \         \human-readable. When expected as an input type, any string (such as \         \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."++-- | Directive.+data Directive = Directive Name Arguments+    deriving (Eq, Show)++-- | Directive processing status.+data Status+    = Skip -- ^ Skip the selection and stop directive processing+    | Include Directive -- ^ The directive was processed, try other handlers+    | Continue Directive -- ^ Directive handler mismatch, try other handlers++-- | Takes a list of directives, handles supported directives and excludes them+--   from the result. If the selection should be skipped, returns 'Nothing'.+selection :: [Directive] -> Maybe [Directive]+selection = foldr go (Just [])+  where+    go directive' directives' =+        case (skip . include) (Continue directive') of+            (Include _) -> directives'+            Skip -> Nothing+            (Continue x) -> (x :) <$> directives'++handle :: (Directive -> Status) -> Status -> Status+handle _ Skip = Skip+handle handler (Continue directive) = handler directive+handle handler (Include directive) = handler directive++-- * Directive implementations++skip :: Status -> Status+skip = handle skip'+  where+    skip' directive'@(Directive "skip" (Arguments arguments)) =+        case HashMap.lookup "if" arguments of+            (Just (Boolean True)) -> Skip+            _ -> Include directive'+    skip' directive' = Continue directive'++include :: Status -> Status+include = handle include'+  where+    include' directive'@(Directive "include" (Arguments arguments)) =+        case HashMap.lookup "if" arguments of+            (Just (Boolean True)) -> Include directive'+            _ -> Skip+    include' directive' = Continue directive'

@@ -1,57 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Language.GraphQL.Type.Directive-    ( Directive(..)-    , selection-    ) where--import qualified Data.HashMap.Strict as HashMap-import Language.GraphQL.AST (Name)-import Language.GraphQL.AST.Core-import Language.GraphQL.Type.Definition---- | Directive.-data Directive = Directive Name Arguments-    deriving (Eq, Show)---- | Directive processing status.-data Status-    = Skip -- ^ Skip the selection and stop directive processing-    | Include Directive -- ^ The directive was processed, try other handlers-    | Continue Directive -- ^ Directive handler mismatch, try other handlers---- | Takes a list of directives, handles supported directives and excludes them---   from the result. If the selection should be skipped, returns 'Nothing'.-selection :: [Directive] -> Maybe [Directive]-selection = foldr go (Just [])-  where-    go directive' directives' =-        case (skip . include) (Continue directive') of-            (Include _) -> directives'-            Skip -> Nothing-            (Continue x) -> (x :) <$> directives'--handle :: (Directive -> Status) -> Status -> Status-handle _ Skip = Skip-handle handler (Continue directive) = handler directive-handle handler (Include directive) = handler directive---- * Directive implementations--skip :: Status -> Status-skip = handle skip'-  where-    skip' directive'@(Directive "skip" (Arguments arguments)) =-        case HashMap.lookup "if" arguments of-            (Just (Boolean True)) -> Skip-            _ -> Include directive'-    skip' directive' = Continue directive'--include :: Status -> Status-include = handle include'-  where-    include' directive'@(Directive "include" (Arguments arguments)) =-        case HashMap.lookup "if" arguments of-            (Just (Boolean True)) -> Include directive'-            _ -> Skip-    include' directive' = Continue directive'

@@ -0,0 +1,91 @@+{- 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 ExplicitForAll #-}++module Language.GraphQL.Type.Internal+    ( AbstractType(..)+    , CompositeType(..)+    , collectReferencedTypes+    ) where++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL.AST (Name)+import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Schema++-- | These types may describe the parent context of a selection set.+data CompositeType m+    = CompositeUnionType (Out.UnionType m)+    | CompositeObjectType (Out.ObjectType m)+    | CompositeInterfaceType (Out.InterfaceType m)+    deriving Eq++-- | These types may describe the parent context of a selection set.+data AbstractType m+    = AbstractUnionType (Out.UnionType m)+    | AbstractInterfaceType (Out.InterfaceType m)+    deriving Eq++-- | Traverses the schema and finds all referenced types.+collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)+collectReferencedTypes schema =+    let queryTypes = traverseObjectType (query schema) HashMap.empty+     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema+  where+    collect traverser typeName element foundTypes+        | HashMap.member typeName foundTypes = foundTypes+        | otherwise = traverser $ HashMap.insert typeName element foundTypes+    visitFields (Out.Field _ outputType arguments) foundTypes+        = traverseOutputType outputType+        $ foldr visitArguments foundTypes arguments+    visitArguments (In.Argument _ inputType _) = traverseInputType inputType+    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType+    getField (Out.ValueResolver field _) = field+    getField (Out.EventStreamResolver field _ _) = field+    traverseInputType (In.InputObjectBaseType objectType) =+        let (In.InputObjectType typeName _ inputFields) = objectType+            element = InputObjectType objectType+            traverser = flip (foldr visitInputFields) inputFields+         in collect traverser typeName element+    traverseInputType (In.ListBaseType listType) =+        traverseInputType listType+    traverseInputType (In.ScalarBaseType scalarType) =+        let (Definition.ScalarType typeName _) = scalarType+         in collect Prelude.id typeName (ScalarType scalarType)+    traverseInputType (In.EnumBaseType enumType) =+        let (Definition.EnumType typeName _ _) = enumType+         in collect Prelude.id typeName (EnumType enumType)+    traverseOutputType (Out.ObjectBaseType objectType) =+        traverseObjectType objectType+    traverseOutputType (Out.InterfaceBaseType interfaceType) =+        traverseInterfaceType interfaceType+    traverseOutputType (Out.UnionBaseType unionType) =+        let (Out.UnionType typeName _ types) = unionType+            traverser = flip (foldr traverseObjectType) types+         in collect traverser typeName (UnionType unionType)+    traverseOutputType (Out.ListBaseType listType) =+        traverseOutputType listType+    traverseOutputType (Out.ScalarBaseType scalarType) =+        let (Definition.ScalarType typeName _) = scalarType+         in collect Prelude.id typeName (ScalarType scalarType)+    traverseOutputType (Out.EnumBaseType enumType) =+        let (Definition.EnumType typeName _ _) = enumType+         in collect Prelude.id typeName (EnumType enumType)+    traverseObjectType objectType foundTypes =+        let (Out.ObjectType typeName _ interfaces fields) = objectType+            element = ObjectType objectType+            traverser = polymorphicTraverser interfaces (getField <$> fields)+         in collect traverser typeName element foundTypes+    traverseInterfaceType interfaceType foundTypes =+        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType+            element = InterfaceType interfaceType+            traverser = polymorphicTraverser interfaces fields+         in collect traverser typeName element foundTypes+    polymorphicTraverser interfaces fields+        = flip (foldr visitFields) fields+        . flip (foldr traverseInterfaceType) interfaces

@@ -1,18 +1,28 @@+{- 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 ExplicitForAll #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} --- | Output types and values.+-- | Output types and values, monad transformer stack used by the @GraphQL@+-- resolvers. -- -- This module is intended to be imported qualified, to avoid name clashes -- with 'Language.GraphQL.Type.In'. module Language.GraphQL.Type.Out-    ( Field(..)+    ( Context(..)+    , Field(..)     , InterfaceType(..)     , ObjectType(..)+    , Resolve+    , Subscribe     , Resolver(..)+    , SourceEventStream     , Type(..)     , UnionType(..)+    , argument     , isNonNullType     , pattern EnumBaseType     , pattern InterfaceBaseType@@ -22,26 +32,20 @@     , pattern UnionBaseType     ) where +import Conduit+import Control.Monad.Trans.Reader (ReaderT, asks) import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (fromMaybe) import Data.Text (Text) import Language.GraphQL.AST (Name)-import Language.GraphQL.Trans import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In --- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error--- information (if an error has occurred). @m@ is an arbitrary monad, usually--- 'IO'.------ Resolving a field can result in a leaf value or an object, which is--- represented as a list of nested resolvers, used to resolve the fields of that--- object.-data Resolver m = Resolver (Field m) (ActionT m Value)- -- | Object type definition. -----   Almost all of the GraphQL types you define will be object types. Object---   types have a name, but most importantly describe their fields.+-- Almost all of the GraphQL types you define will be object types. Object+-- types have a name, but most importantly describe their fields. data ObjectType m = ObjectType     Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m)) @@ -166,3 +170,43 @@ isNonNullType (NonNullUnionType _) = True isNonNullType (NonNullListType _) = True isNonNullType _ = False++-- | Resolution context holds resolver arguments and the root value.+data Context = Context+    { arguments :: Arguments+    , values :: Value+    }++-- | Monad transformer stack used by the resolvers for determining the resolved+-- value of a field.+type Resolve m = ReaderT Context m Value++-- | Monad transformer stack used by the resolvers for determining the resolved+-- event stream of a subscription field.+type Subscribe m = ReaderT Context m (SourceEventStream m)++-- | A source stream represents the sequence of events, each of which will+-- trigger a GraphQL execution corresponding to that event.+type SourceEventStream m = ConduitT () Value m ()++-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver'+-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves+-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a+-- root subscription type.+--+-- The resolvers aren't part of the 'Field' itself because not all fields+-- have resolvers (interface fields don't have an implementation).+data Resolver m+    = ValueResolver (Field m) (Resolve m)+    | EventStreamResolver (Field m) (Resolve m) (Subscribe m)++-- | Retrieves an argument by its name. If the argument with this name couldn't+-- be found, returns 'Null' (i.e. the argument is assumed to+-- be optional then).+argument :: Monad m => Name -> Resolve m+argument argumentName = do+    argumentValue <- asks $ lookupArgument . arguments+    pure $ fromMaybe Null argumentValue+  where+    lookupArgument (Arguments argumentMap) =+        HashMap.lookup argumentName argumentMap

@@ -1,18 +1,10 @@-{-# LANGUAGE ExplicitForAll #-}- -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema-    ( AbstractType(..)-    , CompositeType(..)-    , Schema(..)+    ( Schema(..)     , Type(..)-    , collectReferencedTypes     ) where -import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Language.GraphQL.AST.Document (Name) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out@@ -27,19 +19,6 @@     | UnionType (Out.UnionType m)     deriving Eq --- | These types may describe the parent context of a selection set.-data CompositeType m-    = CompositeUnionType (Out.UnionType m)-    | CompositeObjectType (Out.ObjectType m)-    | CompositeInterfaceType (Out.InterfaceType m)-    deriving Eq---- | These types may describe the parent context of a selection set.-data AbstractType m-    = AbstractUnionType (Out.UnionType m)-    | AbstractInterfaceType (Out.InterfaceType m)-    deriving Eq- -- | A Schema is created by supplying the root types of each type of operation, --   query and mutation (optional). A schema definition is then supplied to the --   validator and executor.@@ -50,63 +29,5 @@ data Schema m = Schema     { query :: Out.ObjectType m     , mutation :: Maybe (Out.ObjectType m)+    , subscription :: Maybe (Out.ObjectType m)     }---- | Traverses the schema and finds all referenced types.-collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)-collectReferencedTypes schema =-    let queryTypes = traverseObjectType (query schema) HashMap.empty-     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema-  where-    collect traverser typeName element foundTypes-        | HashMap.member typeName foundTypes = foundTypes-        | otherwise = traverser $ HashMap.insert typeName element foundTypes-    visitFields (Out.Field _ outputType arguments) foundTypes-        = traverseOutputType outputType-        $ foldr visitArguments foundTypes arguments-    visitArguments (In.Argument _ inputType _) = traverseInputType inputType-    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType-    traverseInputType (In.InputObjectBaseType objectType) =-        let (In.InputObjectType typeName _ inputFields) = objectType-            element = InputObjectType objectType-            traverser = flip (foldr visitInputFields) inputFields-         in collect traverser typeName element-    traverseInputType (In.ListBaseType listType) =-        traverseInputType listType-    traverseInputType (In.ScalarBaseType scalarType) =-        let (Definition.ScalarType typeName _) = scalarType-         in collect Prelude.id typeName (ScalarType scalarType)-    traverseInputType (In.EnumBaseType enumType) =-        let (Definition.EnumType typeName _ _) = enumType-         in collect Prelude.id typeName (EnumType enumType)-    traverseOutputType (Out.ObjectBaseType objectType) =-        traverseObjectType objectType-    traverseOutputType (Out.InterfaceBaseType interfaceType) =-        traverseInterfaceType interfaceType-    traverseOutputType (Out.UnionBaseType unionType) =-        let (Out.UnionType typeName _ types) = unionType-            traverser = flip (foldr traverseObjectType) types-         in collect traverser typeName (UnionType unionType)-    traverseOutputType (Out.ListBaseType listType) =-        traverseOutputType listType-    traverseOutputType (Out.ScalarBaseType scalarType) =-        let (Definition.ScalarType typeName _) = scalarType-         in collect Prelude.id typeName (ScalarType scalarType)-    traverseOutputType (Out.EnumBaseType enumType) =-        let (Definition.EnumType typeName _ _) = enumType-         in collect Prelude.id typeName (EnumType enumType)-    traverseObjectType objectType foundTypes =-        let (Out.ObjectType typeName _ interfaces resolvers) = objectType-            element = ObjectType objectType-            fields = extractObjectField <$> resolvers-            traverser = polymorphicTraverser interfaces fields-         in collect traverser typeName element foundTypes-    traverseInterfaceType interfaceType foundTypes =-        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType-            element = InterfaceType interfaceType-            traverser = polymorphicTraverser interfaces fields-         in collect traverser typeName element foundTypes-    polymorphicTraverser interfaces fields-        = flip (foldr visitFields) fields-        . flip (foldr traverseInterfaceType) interfaces-    extractObjectField (Out.Resolver field _) = field

@@ -0,0 +1,97 @@+{- 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 ExplicitForAll #-}+{-# LANGUAGE LambdaCase #-}++-- | GraphQL validator.+module Language.GraphQL.Validate+    ( Error(..)+    , Path(..)+    , document+    , module Language.GraphQL.Validate.Rules+    ) where++import Control.Monad.Trans.Reader (Reader, asks, runReader)+import Data.Foldable (foldrM)+import Data.Sequence (Seq(..), (><), (|>))+import qualified Data.Sequence as Seq+import Data.Text (Text)+import Language.GraphQL.AST.Document+import Language.GraphQL.Type.Schema+import Language.GraphQL.Validate.Rules++data Context m = Context+    { ast :: Document+    , schema :: Schema m+    , rules :: [Rule]+    }++type ValidateT m = Reader (Context m) (Seq Error)++-- | If an error can be associated to a particular field in the GraphQL result,+-- it must contain an entry with the key path that details the path of the+-- response field which experienced the error. This allows clients to identify+-- whether a null result is intentional or caused by a runtime error.+data Path+    = Segment Text -- ^ Field name.+    | Index Int -- ^ List index if a field returned a list.+    deriving (Eq, Show)++-- | Validation error.+data Error = Error+    { message :: String+    , locations :: [Location]+    , path :: [Path]+    } deriving (Eq, Show)++-- | Validates a document and returns a list of found errors. If the returned+-- list is empty, the document is valid.+document :: forall m. Schema m -> [Rule] -> Document -> Seq Error+document schema' rules' document' =+    runReader (foldrM go Seq.empty document') context+  where+    context = Context+        { ast = document'+        , schema = schema'+        , rules = rules'+        }+    go definition' accumulator = (accumulator ><) <$> definition definition'++definition :: forall m. Definition -> ValidateT m+definition = \case+    definition'@(ExecutableDefinition executableDefinition' _) -> do+        applied <- applyRules definition'+        children <- executableDefinition executableDefinition'+        pure $ children >< applied+    definition' -> applyRules definition'+  where+    applyRules definition' = foldr (ruleFilter definition') Seq.empty+        <$> asks rules+    ruleFilter definition' (DefinitionRule rule) accumulator+        | Just message' <- rule definition' =+            accumulator |> Error+                { message = message'+                , locations = [definitionLocation definition']+                , path = []+                }+        | otherwise = accumulator+    definitionLocation (ExecutableDefinition _ location) = location+    definitionLocation (TypeSystemDefinition _ location) = location+    definitionLocation (TypeSystemExtension _ location) = location++executableDefinition :: forall m. ExecutableDefinition -> ValidateT m+executableDefinition (DefinitionOperation definition') =+    operationDefinition definition'+executableDefinition (DefinitionFragment definition') =+    fragmentDefinition definition'++operationDefinition :: forall m. OperationDefinition -> ValidateT m+operationDefinition (SelectionSet _operation) =+    pure Seq.empty+operationDefinition (OperationDefinition _type _name _variables _directives _selection) =+    pure Seq.empty++fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m+fragmentDefinition _fragment = pure Seq.empty

@@ -0,0 +1,31 @@+{- 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/. -}++-- | This module contains default rules defined in the GraphQL specification.+module Language.GraphQL.Validate.Rules+    ( Rule(..)+    , executableDefinitionsRule+    , specifiedRules+    ) where++import Language.GraphQL.AST.Document++-- | 'Rule' assigns a function to each AST node that can be validated. If the+-- validation fails, the function should return an error message, or 'Nothing'+-- otherwise.+newtype Rule+    = DefinitionRule (Definition -> Maybe String)++-- | Default reules given in the specification.+specifiedRules :: [Rule]+specifiedRules =+    [ executableDefinitionsRule+    ]++-- | Definition must be OperationDefinition or FragmentDefinition.+executableDefinitionsRule :: Rule+executableDefinitionsRule = DefinitionRule go+  where+    go (ExecutableDefinition _definition _) = Nothing+    go _ = Just "Definition must be OperationDefinition or FragmentDefinition."

@@ -0,0 +1,40 @@+{- 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 ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Test helpers.+module Test.Hspec.GraphQL+    ( shouldResolve+    , shouldResolveTo+    ) where++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text)+import Language.GraphQL.Error+import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)++-- | Asserts that a query resolves to some value.+shouldResolveTo+    :: Either (ResponseEventStream IO Aeson.Value) Aeson.Object+    -> Aeson.Object+    -> Expectation+shouldResolveTo (Right actual) expected = actual `shouldBe` expected+shouldResolveTo _ _ = expectationFailure+    "the query is expected to resolve to a value, but it resolved to an event stream"++-- | Asserts that the response doesn't contain any errors.+shouldResolve+    :: (Text -> IO (Either (ResponseEventStream IO Aeson.Value) Aeson.Object))+    -> Text+    -> Expectation+shouldResolve executor query = do+    actual <- executor query+    case actual of+        Right response ->+            response `shouldNotSatisfy` HashMap.member "errors"+        _ -> expectationFailure+            "the query is expected to resolve to a value, but it resolved to an event stream"

@@ -129,10 +129,11 @@      it "parses schema extension with an operation type and directive" $         let newDirective = Directive "newDirective" []-            testSchemaExtension = TypeSystemExtension-                $ SchemaExtension+            schemaExtension = SchemaExtension                 $ SchemaOperationExtension [newDirective]                 $ OperationTypeDefinition Query "Query" :| []+            testSchemaExtension = TypeSystemExtension schemaExtension+                $ Location 1 1             query = [r|extend schema @newDirective { query: Query }|]          in parse document "" query `shouldParse` (testSchemaExtension :| []) @@ -147,5 +148,24 @@         parse document "" `shouldFailOn` [r|             query ($book: String = "Zarathustra", $author: String = $book) {               title+            }+        |]++    it "parses documents beginning with a comment" $+        parse document "" `shouldSucceedOn` [r|+            """+            Query+            """+            type Query {+                queryField: String+            }+        |]++    it "parses subscriptions" $+        parse document "" `shouldSucceedOn` [r|+            subscription NewMessages {+              newMessage(roomId: 123) {+                sender+              }             }         |]

@@ -4,6 +4,7 @@     ) where  import qualified Data.Aeson as Aeson+import qualified Data.Sequence as Seq import Language.GraphQL.Error import Test.Hspec ( Spec                   , describe@@ -14,11 +15,6 @@ spec :: Spec spec = describe "singleError" $     it "constructs an error with the given message" $-        let expected = Aeson.object-                [-                    ("errors", Aeson.toJSON-                        [ Aeson.object [("message", "Message.")]-                        ]-                    )-                ]+        let errors'' = Seq.singleton $ Error "Message." []+            expected = Response Aeson.Null errors''          in singleError "Message." `shouldBe` expected

@@ -1,11 +1,16 @@+{- 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 Language.GraphQL.ExecuteSpec     ( spec     ) where +import Control.Exception (SomeException) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson-import Data.Functor.Identity (Identity(..))+import Data.Conduit import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Language.GraphQL.AST (Name)@@ -14,62 +19,95 @@ import Language.GraphQL.Execute import Language.GraphQL.Type as Type import Language.GraphQL.Type.Out as Out-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) -schema :: Schema Identity-schema = Schema {query = queryType, mutation = Nothing}+schema :: Schema (Either SomeException)+schema = Schema+    { query = queryType+    , mutation = Nothing+    , subscription = Just subscriptionType+    } -queryType :: Out.ObjectType Identity+queryType :: Out.ObjectType (Either SomeException) queryType = Out.ObjectType "Query" Nothing []-    $ HashMap.singleton "philosopher"-    $ Out.Resolver philosopherField-    $ pure-    $ Type.Object mempty+    $ HashMap.singleton "philosopher" +    $ ValueResolver philosopherField+    $ pure $ Type.Object mempty   where     philosopherField =         Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty -philosopherType :: Out.ObjectType Identity+philosopherType :: Out.ObjectType (Either SomeException) philosopherType = Out.ObjectType "Philosopher" Nothing []     $ HashMap.fromList resolvers   where     resolvers =-        [ ("firstName", firstNameResolver)-        , ("lastName", lastNameResolver)+        [ ("firstName", ValueResolver firstNameField firstNameResolver)+        , ("lastName", ValueResolver lastNameField lastNameResolver)         ]-    firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"-    lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"-    firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty-    lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty+    firstNameField =+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty+    firstNameResolver = pure $ Type.String "Friedrich"+    lastNameField+        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty+    lastNameResolver = pure $ Type.String "Nietzsche" +subscriptionType :: Out.ObjectType (Either SomeException)+subscriptionType = Out.ObjectType "Subscription" Nothing []+    $ HashMap.singleton "newQuote"+    $ EventStreamResolver quoteField (pure $ Type.Object mempty)+    $ pure $ yield $ Type.Object mempty+  where+    quoteField =+        Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty++quoteType :: Out.ObjectType (Either SomeException)+quoteType = Out.ObjectType "Quote" Nothing []+    $ HashMap.singleton "quote"+    $ ValueResolver quoteField+    $ pure "Naturam expelles furca, tamen usque recurret."+  where+    quoteField =+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty+ spec :: Spec spec =     describe "execute" $ do-        it "skips unknown fields" $-            let expected = Aeson.object-                    [ "data" .= Aeson.object+        context "Query" $ do+            it "skips unknown fields" $+                let data'' = Aeson.object                         [ "philosopher" .= Aeson.object                             [ "firstName" .= ("Friedrich" :: String)                             ]                         ]-                    ]-                execute' = execute schema (mempty :: HashMap Name Aeson.Value)-                actual = runIdentity-                    $ either parseError execute'-                    $ parse document "" "{ philosopher { firstName surname } }"-             in actual `shouldBe` expected-        it "merges selections" $-            let expected = Aeson.object-                    [ "data" .= Aeson.object+                    expected = Response data'' mempty+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)+                    Right (Right actual) = either (pure . parseError) execute'+                        $ parse document "" "{ philosopher { firstName surname } }"+                in actual `shouldBe` expected+            it "merges selections" $+                let data'' = Aeson.object                         [ "philosopher" .= Aeson.object                             [ "firstName" .= ("Friedrich" :: String)                             , "lastName" .= ("Nietzsche" :: String)                             ]                         ]-                    ]-                execute' = execute schema (mempty :: HashMap Name Aeson.Value)-                actual = runIdentity-                    $ either parseError execute'-                    $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"-             in actual `shouldBe` expected+                    expected = Response data'' mempty+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)+                    Right (Right actual) = either (pure . parseError) execute'+                        $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"+                in actual `shouldBe` expected+        context "Subscription" $+            it "subscribes" $+                let data'' = Aeson.object+                        [ "newQuote" .= Aeson.object+                            [ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String)+                            ]+                        ]+                    expected = Response data'' mempty+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)+                    Right (Left stream) = either (pure . parseError) execute'+                        $ parse document "" "subscription { newQuote { quote } }"+                    Right (Just actual) = runConduit $ stream .| await+                in actual `shouldBe` expected

@@ -0,0 +1,171 @@+{- 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 #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.GraphQL.ValidateSpec+    ( spec+    ) where++import Data.Sequence (Seq(..))+import qualified Data.Sequence as Seq+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text)+import qualified Language.GraphQL.AST as AST+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Validate+import Test.Hspec (Spec, describe, it, shouldBe)+import Text.Megaparsec (parse)+import Text.RawString.QQ (r)++schema :: Schema IO+schema = Schema+    { query = queryType+    , mutation = Nothing+    , subscription = Nothing+    } ++queryType :: ObjectType IO+queryType = ObjectType "Query" Nothing []+    $ HashMap.singleton "dog" dogResolver+  where+    dogField = Field Nothing (Out.NamedObjectType dogType) mempty+    dogResolver = ValueResolver dogField $ pure Null++dogCommandType :: EnumType+dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList+    [ ("SIT", EnumValue Nothing)+    , ("DOWN", EnumValue Nothing)+    , ("HEEL", EnumValue Nothing)+    ]++dogType :: ObjectType IO+dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("nickname", nicknameResolver)+    , ("barkVolume", barkVolumeResolver)+    , ("doesKnowCommand", doesKnowCommandResolver)+    , ("isHousetrained", isHousetrainedResolver)+    , ("owner", ownerResolver)+    ]+  where+    nameField = Field Nothing (Out.NonNullScalarType string) mempty+    nameResolver = ValueResolver nameField $ pure "Name"+    nicknameField = Field Nothing (Out.NamedScalarType string) mempty+    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"+    barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty+    barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)+        $ HashMap.singleton "dogCommand"+        $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing+    doesKnowCommandResolver = ValueResolver doesKnowCommandField+        $ pure $ Boolean True+    isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)+        $ HashMap.singleton "atOtherHomes"+        $ In.Argument Nothing (In.NamedScalarType boolean) Nothing+    isHousetrainedResolver = ValueResolver isHousetrainedField+        $ pure $ Boolean True+    ownerField = Field Nothing (Out.NamedObjectType humanType) mempty+    ownerResolver = ValueResolver ownerField $ pure Null++sentientType :: InterfaceType IO+sentientType = InterfaceType "Sentient" Nothing []+    $ HashMap.singleton "name"+    $ Field Nothing (Out.NonNullScalarType string) mempty++petType :: InterfaceType IO+petType = InterfaceType "Pet" Nothing []+    $ HashMap.singleton "name"+    $ Field Nothing (Out.NonNullScalarType string) mempty+{-+alienType :: ObjectType IO+alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("homePlanet", homePlanetResolver)+    ]+  where+    nameField = Field Nothing (Out.NonNullScalarType string) mempty+    nameResolver = ValueResolver nameField $ pure "Name"+    homePlanetField =+        Field Nothing (Out.NamedScalarType string) mempty+    homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"+-}+humanType :: ObjectType IO+humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("pets", petsResolver)+    ]+  where+    nameField = Field Nothing (Out.NonNullScalarType string) mempty+    nameResolver = ValueResolver nameField $ pure "Name"+    petsField =+        Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty+    petsResolver = ValueResolver petsField $ pure $ List []+{-+catCommandType :: EnumType+catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList+    [ ("JUMP", EnumValue Nothing)+    ]++catType :: ObjectType IO+catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("nickname", nicknameResolver)+    , ("doesKnowCommand", doesKnowCommandResolver)+    , ("meowVolume", meowVolumeResolver)+    ]+  where+    nameField = Field Nothing (Out.NonNullScalarType string) mempty+    nameResolver = ValueResolver nameField $ pure "Name"+    nicknameField = Field Nothing (Out.NamedScalarType string) mempty+    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)+        $ HashMap.singleton "catCommand"+        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing+    doesKnowCommandResolver = ValueResolver doesKnowCommandField+        $ pure $ Boolean True+    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty+    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2++catOrDogType :: UnionType IO+catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]++dogOrHumanType :: UnionType IO+dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]++humanOrAlienType :: UnionType IO+humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType]+-}+validate :: Text -> Seq Error+validate queryString =+    case parse AST.document "" queryString of+        Left _ -> Seq.empty+        Right ast -> document schema specifiedRules ast++spec :: Spec+spec =+    describe "document" $+        it "rejects type definitions" $+            let queryString = [r|+              query getDogName {+                dog {+                  name+                  color+                }+              }++              extend type Dog {+                color: String+              }+            |]+                expected = Error+                    { message =+                        "Definition must be OperationDefinition or FragmentDefinition."+                    , locations = [AST.Location 9 15]+                    , path = []+                    }+             in validate queryString `shouldBe` Seq.singleton expected

@@ -1,3 +1,7 @@+{- 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 #-} {-# LANGUAGE QuasiQuotes #-} module Test.DirectiveSpec@@ -10,21 +14,21 @@ import Language.GraphQL import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec (Spec, describe, it)+import Test.Hspec.GraphQL import Text.RawString.QQ (r)  experimentalResolver :: Schema IO-experimentalResolver = Schema { query = queryType, mutation = Nothing }+experimentalResolver = Schema+    { query = queryType, mutation = Nothing, subscription = Nothing }   where-    resolver = pure $ Int 5     queryType = Out.ObjectType "Query" Nothing []         $ HashMap.singleton "experimentalField"-        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver+        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)+        $ pure $ Int 5 -emptyObject :: Aeson.Value-emptyObject = object-    [ "data" .= object []-    ]+emptyObject :: Aeson.Object+emptyObject = HashMap.singleton "data" $ object []  spec :: Spec spec =@@ -37,7 +41,7 @@             |]              actual <- graphql experimentalResolver sourceQuery-            actual `shouldBe` emptyObject+            actual `shouldResolveTo` emptyObject          it "should not skip fields if @skip is false" $ do             let sourceQuery = [r|@@ -45,14 +49,12 @@                 experimentalField @skip(if: false)               }             |]-                expected = object-                    [ "data" .= object+                expected = HashMap.singleton "data"+                    $ object                         [ "experimentalField" .= (5 :: Int)                         ]-                    ]-             actual <- graphql experimentalResolver sourceQuery-            actual `shouldBe` expected+            actual `shouldResolveTo` expected          it "should skip fields if @include is false" $ do             let sourceQuery = [r|@@ -62,7 +64,7 @@             |]              actual <- graphql experimentalResolver sourceQuery-            actual `shouldBe` emptyObject+            actual `shouldResolveTo` emptyObject          it "should be able to @skip a fragment spread" $ do             let sourceQuery = [r|@@ -76,7 +78,7 @@             |]              actual <- graphql experimentalResolver sourceQuery-            actual `shouldBe` emptyObject+            actual `shouldResolveTo` emptyObject          it "should be able to @skip an inline fragment" $ do             let sourceQuery = [r|@@ -88,4 +90,4 @@             |]              actual <- graphql experimentalResolver sourceQuery-            actual `shouldBe` emptyObject+            actual `shouldResolveTo` emptyObject

@@ -1,23 +1,22 @@+{- 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 #-} {-# LANGUAGE QuasiQuotes #-} module Test.FragmentSpec     ( spec     ) where -import Data.Aeson (object, (.=))+import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out-import Test.Hspec-    ( Spec-    , describe-    , it-    , shouldBe-    , shouldNotSatisfy-    )+import Test.Hspec (Spec, describe, it)+import Test.Hspec.GraphQL import Text.RawString.QQ (r)  size :: (Text, Value)@@ -46,33 +45,33 @@   } }|] -hasErrors :: Aeson.Value -> Bool-hasErrors (Aeson.Object object') = HashMap.member "errors" object'-hasErrors _ = True- shirtType :: Out.ObjectType IO shirtType = Out.ObjectType "Shirt" Nothing []     $ HashMap.fromList-        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)-        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)+        [ ("size", sizeFieldType)+        , ("circumference", circumferenceFieldType)         ]  hatType :: Out.ObjectType IO hatType = Out.ObjectType "Hat" Nothing []     $ HashMap.fromList-        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)-        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)+        [ ("size", sizeFieldType)+        , ("circumference", circumferenceFieldType)         ] -circumferenceFieldType :: Out.Field IO-circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty+circumferenceFieldType :: Out.Resolver IO+circumferenceFieldType+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)+    $ pure $ snd circumference -sizeFieldType :: Out.Field IO-sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty+sizeFieldType :: Out.Resolver IO+sizeFieldType+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)+    $ pure $ snd size  toSchema :: Text -> (Text, Value) -> Schema IO toSchema t (_, resolve) = Schema-    { query = queryType, mutation = Nothing }+    { query = queryType, mutation = Nothing, subscription = Nothing }   where     unionMember = if t == "Hat" then hatType else shirtType     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty@@ -83,8 +82,8 @@             "size" -> shirtType             _ -> Out.ObjectType "Query" Nothing []                 $ HashMap.fromList-                    [ ("garment", Out.Resolver garmentField $ pure resolve)-                    , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")+                    [ ("garment", ValueResolver garmentField (pure resolve))+                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))                     ]  spec :: Spec@@ -92,25 +91,23 @@     describe "Inline fragment executor" $ do         it "chooses the first selection if the type matches" $ do             actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery-            let expected = object-                    [ "data" .= object-                        [ "garment" .= object+            let expected = HashMap.singleton "data"+                    $ Aeson.object+                        [ "garment" .= Aeson.object                             [ "circumference" .= (60 :: Int)                             ]                         ]-                    ]-             in actual `shouldBe` expected+             in actual `shouldResolveTo` expected          it "chooses the last selection if the type matches" $ do             actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery-            let expected = object-                    [ "data" .= object-                        [ "garment" .= object+            let expected = HashMap.singleton "data"+                    $ Aeson.object+                        [ "garment" .= Aeson.object                             [ "size" .= ("L" :: Text)                             ]                         ]-                    ]-             in actual `shouldBe` expected+             in actual `shouldResolveTo` expected          it "embeds inline fragments without type" $ do             let sourceQuery = [r|{@@ -124,15 +121,14 @@                 resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])              actual <- graphql (toSchema "garment" resolvers) sourceQuery-            let expected = object-                    [ "data" .= object-                        [ "garment" .= object+            let expected = HashMap.singleton "data"+                    $ Aeson.object+                        [ "garment" .= Aeson.object                             [ "circumference" .= (60 :: Int)                             , "size" .= ("L" :: Text)                             ]                         ]-                    ]-             in actual `shouldBe` expected+             in actual `shouldResolveTo` expected          it "evaluates fragments on Query" $ do             let sourceQuery = [r|{@@ -140,9 +136,7 @@                 size               }             }|]--            actual <- graphql (toSchema "size" size) sourceQuery-            actual `shouldNotSatisfy` hasErrors+             in graphql (toSchema "size" size) `shouldResolve` sourceQuery      describe "Fragment spread executor" $ do         it "evaluates fragment spreads" $ do@@ -157,12 +151,11 @@             |]              actual <- graphql (toSchema "circumference" circumference) sourceQuery-            let expected = object-                    [ "data" .= object+            let expected = HashMap.singleton "data"+                    $ Aeson.object                         [ "circumference" .= (60 :: Int)                         ]-                    ]-             in actual `shouldBe` expected+             in actual `shouldResolveTo` expected          it "evaluates nested fragments" $ do             let sourceQuery = [r|@@ -182,19 +175,16 @@             |]              actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery-            let expected = object-                    [ "data" .= object-                        [ "garment" .= object+            let expected = HashMap.singleton "data"+                    $ Aeson.object+                        [ "garment" .= Aeson.object                             [ "circumference" .= (60 :: Int)                             ]                         ]-                    ]-             in actual `shouldBe` expected+             in actual `shouldResolveTo` expected          it "rejects recursive fragments" $ do-            let expected = object-                    [ "data" .= object []-                    ]+            let expected = HashMap.singleton "data" $ Aeson.object []                 sourceQuery = [r|               {                 ...circumferenceFragment@@ -206,7 +196,7 @@             |]              actual <- graphql (toSchema "circumference" circumference) sourceQuery-            actual `shouldBe` expected+            actual `shouldResolveTo` expected          it "considers type condition" $ do             let sourceQuery = [r|@@ -223,12 +213,11 @@                 size               }             |]-                expected = object-                    [ "data" .= object-                        [ "garment" .= object+                expected = HashMap.singleton "data"+                    $ Aeson.object+                        [ "garment" .= Aeson.object                             [ "circumference" .= (60 :: Int)                             ]                         ]-                    ]             actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery-            actual `shouldBe` expected+            actual `shouldResolveTo` expected

@@ -1,3 +1,7 @@+{- 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 #-} {-# LANGUAGE QuasiQuotes #-} module Test.RootOperationSpec@@ -7,30 +11,34 @@ import Data.Aeson ((.=), object) import qualified Data.HashMap.Strict as HashMap import Language.GraphQL-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec (Spec, describe, it) import Text.RawString.QQ (r) import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out+import Test.Hspec.GraphQL  hatType :: Out.ObjectType IO hatType = Out.ObjectType "Hat" Nothing []     $ HashMap.singleton "circumference"-    $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)+    $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)     $ pure $ Int 60  schema :: Schema IO schema = Schema-    (Out.ObjectType "Query" Nothing [] hatField)-    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)+    { query = Out.ObjectType "Query" Nothing [] hatFieldResolver+    , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver+    , subscription = Nothing+    }   where     garment = pure $ Object $ HashMap.fromList         [ ("circumference", Int 60)         ]-    incrementField = HashMap.singleton "incrementCircumference"-        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)+    incrementFieldResolver = HashMap.singleton "incrementCircumference"+        $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)         $ pure $ Int 61-    hatField = HashMap.singleton "garment"-        $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment+    hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty+    hatFieldResolver =+        HashMap.singleton "garment" $ ValueResolver hatField garment  spec :: Spec spec =@@ -43,15 +51,14 @@                 }               }             |]-                expected = object-                    [ "data" .= object+                expected = HashMap.singleton "data"+                    $ object                         [ "garment" .= object                             [ "circumference" .= (60 :: Int)                             ]                         ]-                    ]             actual <- graphql schema querySource-            actual `shouldBe` expected+            actual `shouldResolveTo` expected          it "chooses Mutation" $ do             let querySource = [r|@@ -59,10 +66,9 @@                 incrementCircumference               }             |]-                expected = object-                    [ "data" .= object+                expected = HashMap.singleton "data"+                    $ object                         [ "incrementCircumference" .= (61 :: Int)                         ]-                    ]             actual <- graphql schema querySource-            actual `shouldBe` expected+            actual `shouldResolveTo` expected

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Test.StarWars.Data     ( Character+    , StarWarsException(..)     , appearsIn     , artoo     , getDroid@@ -16,12 +17,13 @@     , typeName     ) where -import Data.Functor.Identity (Identity)+import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException) import Control.Applicative (Alternative(..), liftA2)-import Control.Monad.Trans.Except (throwE) import Data.Maybe (catMaybes) import Data.Text (Text)-import Language.GraphQL.Trans+import Data.Typeable (cast)+import Language.GraphQL.Error+import Language.GraphQL.Type  -- * Data -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js@@ -66,9 +68,21 @@ appearsIn (Left  x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: ActionT Identity Text-secretBackstory = ActionT $ throwE "secretBackstory is secret."+data StarWarsException = SecretBackstory | InvalidArguments +instance Show StarWarsException where+    show SecretBackstory = "secretBackstory is secret."+    show InvalidArguments = "Invalid arguments."++instance Exception StarWarsException where+    toException = toException . ResolverException+    fromException e = do+        ResolverException resolverException <- fromException e+        cast resolverException++secretBackstory :: Resolve (Either SomeException)+secretBackstory = throwM SecretBackstory+ typeName :: Character -> Text typeName = either (const "Droid") (const "Human") @@ -161,10 +175,10 @@ getHero 5 = luke getHero _ = artoo -getHuman :: Alternative f => ID -> f Character+getHuman :: ID -> Maybe Character getHuman = fmap Right . getHuman' -getHuman' :: Alternative f => ID -> f Human+getHuman' :: ID -> Maybe Human getHuman' "1000" = pure luke' getHuman' "1001" = pure vader getHuman' "1002" = pure han@@ -172,10 +186,10 @@ getHuman' "1004" = pure tarkin getHuman' _      = empty -getDroid :: Alternative f => ID -> f Character+getDroid :: ID -> Maybe Character getDroid = fmap Left . getDroid' -getDroid' :: Alternative f => ID -> f Droid+getDroid' :: ID -> Maybe Droid getDroid' "2000" = pure threepio getDroid' "2001" = pure artoo' getDroid' _      = empty

@@ -6,7 +6,6 @@  import qualified Data.Aeson as Aeson import Data.Aeson ((.=))-import Data.Functor.Identity (Identity(..)) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL@@ -357,8 +356,11 @@     alderaan = "homePlanet" .= ("Alderaan" :: Text)  testQuery :: Text -> Aeson.Value -> Expectation-testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected+testQuery q expected =+    let Right (Right actual) = graphql schema q+     in Aeson.Object actual `shouldBe` expected  testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams f q expected =-    runIdentity (graphqlSubs schema f q) `shouldBe` expected+    let Right (Right actual) = graphqlSubs schema Nothing f q+     in Aeson.Object actual `shouldBe` expected

@@ -4,14 +4,11 @@     ( schema     ) where +import Control.Monad.Catch (MonadThrow(..), SomeException) import Control.Monad.Trans.Reader (asks)-import Control.Monad.Trans.Except (throwE)-import Control.Monad.Trans.Class (lift)-import Data.Functor.Identity (Identity) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes) import Data.Text (Text)-import Language.GraphQL.Trans import Language.GraphQL.Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out@@ -20,69 +17,97 @@  -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: Schema Identity-schema = Schema { query = queryType, mutation = Nothing }+schema :: Schema (Either SomeException)+schema = Schema+    { query = queryType+    , mutation = Nothing+    , subscription = Nothing+    }   where     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList-        [ ("hero", Out.Resolver heroField hero)-        , ("human", Out.Resolver humanField human)-        , ("droid", Out.Resolver droidField droid)+        [ ("hero", heroFieldResolver)+        , ("human", humanFieldResolver)+        , ("droid", droidFieldResolver)         ]     heroField = Out.Field Nothing (Out.NamedObjectType heroObject)         $ HashMap.singleton "episode"         $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing+    heroFieldResolver = ValueResolver heroField hero     humanField = Out.Field Nothing (Out.NamedObjectType heroObject)         $ HashMap.singleton "id"         $ In.Argument Nothing (In.NonNullScalarType string) Nothing+    humanFieldResolver = ValueResolver humanField human     droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty+    droidFieldResolver = ValueResolver droidField droid -heroObject :: Out.ObjectType Identity+heroObject :: Out.ObjectType (Either SomeException) heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList-    [ ("id", Out.Resolver idFieldType (idField "id"))-    , ("name", Out.Resolver nameFieldType (idField "name"))-    , ("friends", Out.Resolver friendsFieldType (idField "friends"))-    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))-    , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))-    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))-    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))+    [ ("id", idFieldType)+    , ("name", nameFieldType)+    , ("friends", friendsFieldType)+    , ("appearsIn", appearsInField)+    , ("homePlanet", homePlanetFieldType)+    , ("secretBackstory", secretBackstoryFieldType)+    , ("__typename", typenameFieldType)     ]   where-    homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty+    homePlanetFieldType+      = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)+      $ idField "homePlanet" -droidObject :: Out.ObjectType Identity+droidObject :: Out.ObjectType (Either SomeException) droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList-    [ ("id", Out.Resolver idFieldType (idField "id"))-    , ("name", Out.Resolver nameFieldType (idField "name"))-    , ("friends", Out.Resolver friendsFieldType (idField "friends"))-    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))-    , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))-    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))-    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))+    [ ("id", idFieldType)+    , ("name", nameFieldType)+    , ("friends", friendsFieldType)+    , ("appearsIn", appearsInField)+    , ("primaryFunction", primaryFunctionFieldType)+    , ("secretBackstory", secretBackstoryFieldType)+    , ("__typename", typenameFieldType)     ]   where-    primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty+    primaryFunctionFieldType+        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)+        $ idField "primaryFunction" -idFieldType :: Out.Field Identity-idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty+typenameFieldType :: Resolver (Either SomeException)+typenameFieldType+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)+    $ idField "__typename" -nameFieldType :: Out.Field Identity-nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty+idFieldType :: Resolver (Either SomeException)+idFieldType+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)+    $ idField "id" -friendsFieldType :: Out.Field Identity-friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty+nameFieldType :: Resolver (Either SomeException)+nameFieldType+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)+    $ idField "name" -appearsInField :: Out.Field Identity-appearsInField = Out.Field (Just description) fieldType mempty+friendsFieldType :: Resolver (Either SomeException)+friendsFieldType+    = ValueResolver (Out.Field Nothing fieldType mempty)+    $ idField "friends"   where+    fieldType = Out.ListType $ Out.NamedObjectType droidObject++appearsInField :: Resolver (Either SomeException)+appearsInField+    = ValueResolver (Out.Field (Just description) fieldType mempty)+    $ idField "appearsIn"+  where     fieldType = Out.ListType $ Out.NamedEnumType episodeEnum     description = "Which movies they appear in." -secretBackstoryFieldType :: Out.Field Identity-secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty+secretBackstoryFieldType :: Resolver (Either SomeException)+secretBackstoryFieldType = ValueResolver field secretBackstory+  where+    field = Out.Field Nothing (Out.NamedScalarType string) mempty -idField :: Text -> ActionT Identity Value+idField :: Text -> Resolve (Either SomeException) idField f = do-    v <- ActionT $ lift $ asks values+    v <- asks values     let (Object v') = v     pure $ v' HashMap.! f @@ -95,7 +120,7 @@     empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")     jedi = ("JEDI", EnumValue $ Just "Released in 1983.") -hero :: ActionT Identity Value+hero :: Resolve (Either SomeException) hero = do   episode <- argument "episode"   pure $ character $ case episode of@@ -104,23 +129,19 @@       Enum "JEDI" -> getHero 6       _ -> artoo -human :: ActionT Identity Value+human :: Resolve (Either SomeException) human = do     id' <- argument "id"     case id' of-        String i -> do-            humanCharacter <- lift $ return $ getHuman i >>= Just-            case humanCharacter of-                Nothing -> pure Null-                Just e -> pure $ character e-        _ -> ActionT $ throwE "Invalid arguments."+        String i -> pure $ maybe Null character $ getHuman i >>= Just+        _ -> throwM InvalidArguments -droid :: ActionT Identity Value+droid :: Resolve (Either SomeException) droid = do     id' <- argument "id"     case id' of-        String i -> character <$> getDroid i-        _ -> ActionT $ throwE "Invalid arguments."+        String i -> pure $ maybe Null character $ getDroid i >>= Just+        _ -> throwM InvalidArguments  character :: Character -> Value character char = Object $ HashMap.fromList