diff options
41 files changed, 1625 insertions, 802 deletions
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 0000000..665ac93 --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,63 @@ +name: Haskell CI + +on: + push: ~ + pull_request: + branches: [master] + +jobs: + test: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v2 + - uses: actions/setup-haskell@v1 + with: + enable-stack: true + stack-no-global: true + stack-version: latest + + - name: Cache + uses: actions/cache@v2 + with: + path: | + ~/.stack + stack.yaml.lock + key: ${{ runner.os }}-test-${{ hashFiles('**/stack.yaml') }} + restore-keys: ${{ runner.os }}-test- + + - name: Install dependencies + run: stack --no-terminal test --only-snapshot + - name: Run tests + run: stack --no-terminal test --pedantic + - name: Build the documentation + run: | + stack --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs + stack --no-terminal haddock --no-haddock-deps + + lint: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v2 + - uses: actions/setup-haskell@v1 + with: + enable-stack: true + stack-no-global: true + stack-version: latest + + - name: Cache + uses: actions/cache@v2 + with: + path: | + ~/.stack + stack.yaml.lock + key: ${{ runner.os }}-lint-${{ hashFiles('**/stack.yaml') }} + restore-keys: ${{ runner.os }}-lint- + + - name: Build HLint + run: stack --no-terminal build hlint + - name: Install HLint + run: stack --no-terminal install hlint + - name: Lint + run: stack --no-terminal exec hlint -- src tests docs @@ -8,7 +8,8 @@ .cabal-sandbox/ cabal.sandbox.config cabal.project.local -/graphql.cabal # GHC *.hi +*.o +/docs/tutorial/tutorial diff --git a/CHANGELOG.md b/CHANGELOG.md index f42be0a..ae76a2c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,62 @@ The format is based on 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 @@ and this project adheres to ### 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 [](https://hackage.haskell.org/package/graphql) -[](https://semaphoreci.com/belka-ew/graphql) +[](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22) [](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE) GraphQL implementation in Haskell. @@ -13,9 +13,9 @@ be built on top of it. ## 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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 13afb81..dc44c1e 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -5,11 +5,13 @@ title: GraphQL Haskell Tutorial == 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 @@ Since this file is a literate haskell file, we start by importing some dependenc > 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 @@ Next we define our query. > 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 diff --git a/graphql.cabal b/graphql.cabal new file mode 100644 index 0000000..eb514e0 --- /dev/null +++ b/graphql.cabal @@ -0,0 +1,121 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5 + +name: graphql +version: 0.8.0.0 +synopsis: Haskell GraphQL implementation +description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language. +category: Language +homepage: https://github.com/caraus-ecms/graphql#readme +bug-reports: https://github.com/caraus-ecms/graphql/issues +author: Danny Navarro <j@dannynavarro.net>, + Matthías Páll Gissurarson <mpg@mpg.is>, + Sólrún Halla Einarsdóttir <she@mpg.is> +maintainer: belka@caraus.de +copyright: (c) 2019-2020 Eugen Wissner, + (c) 2015-2017 J. Daniel Navarro +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md + LICENSE + docs/tutorial/tutorial.lhs +data-files: + tests/data/kitchen-sink.graphql + tests/data/kitchen-sink.min.graphql + +source-repository head + type: git + location: https://github.com/caraus-ecms/graphql + +library + exposed-modules: + Language.GraphQL + Language.GraphQL.AST + Language.GraphQL.AST.DirectiveLocation + Language.GraphQL.AST.Document + Language.GraphQL.AST.Encoder + Language.GraphQL.AST.Lexer + Language.GraphQL.AST.Parser + Language.GraphQL.Error + Language.GraphQL.Execute + Language.GraphQL.Execute.Coerce + Language.GraphQL.Type + Language.GraphQL.Type.In + Language.GraphQL.Type.Out + Language.GraphQL.Type.Schema + Language.GraphQL.Validate + Test.Hspec.GraphQL + other-modules: + Language.GraphQL.Execute.Execution + Language.GraphQL.Execute.Subscribe + Language.GraphQL.Execute.Transform + Language.GraphQL.Type.Definition + Language.GraphQL.Type.Internal + Language.GraphQL.Validate.Rules + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , conduit + , containers + , exceptions + , hspec-expectations + , megaparsec + , parser-combinators + , scientific + , text + , transformers + , unordered-containers + default-language: Haskell2010 + +test-suite tasty + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Language.GraphQL.AST.EncoderSpec + Language.GraphQL.AST.LexerSpec + Language.GraphQL.AST.ParserSpec + Language.GraphQL.ErrorSpec + Language.GraphQL.Execute.CoerceSpec + Language.GraphQL.ExecuteSpec + Language.GraphQL.Type.OutSpec + Language.GraphQL.ValidateSpec + Test.DirectiveSpec + Test.FragmentSpec + Test.KitchenSinkSpec + Test.RootOperationSpec + Test.StarWars.Data + Test.StarWars.QuerySpec + Test.StarWars.Schema + Paths_graphql + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , aeson + , base >=4.7 && <5 + , conduit + , containers + , exceptions + , graphql + , hspec + , hspec-expectations + , hspec-megaparsec + , megaparsec + , parser-combinators + , raw-strings-qq + , scientific + , text + , transformers + , unordered-containers + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index af29c48..dcdc6c8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: graphql -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Haskell GraphQL implementation description: This package provides a rudimentary parser for the @@ -28,23 +28,26 @@ data-files: dependencies: - aeson - base >= 4.7 && < 5 +- conduit - containers +- exceptions +- hspec-expectations - megaparsec - parser-combinators - scientific - text - transformers - unordered-containers -- vector library: 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 tests: tasty: @@ -57,7 +60,6 @@ tests: dependencies: - graphql - hspec - - hspec-expectations - hspec-megaparsec - QuickCheck - raw-strings-qq diff --git a/semaphoreci.sh b/semaphoreci.sh deleted file mode 100755 index d7c8a93..0000000 --- a/semaphoreci.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/bash - -STACK=$SEMAPHORE_CACHE_DIR/stack -export STACK_ROOT=$SEMAPHORE_CACHE_DIR/.stack - -setup() { - if [ ! -e "$STACK" ] - then - curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack' - fi - if [ -e "$SEMAPHORE_CACHE_DIR/graphql.cabal" ] - then - cp -a $SEMAPHORE_CACHE_DIR/graphql.cabal graphql.cabal - fi - $STACK --no-terminal setup - cp -a graphql.cabal $SEMAPHORE_CACHE_DIR/graphql.cabal -} - -setup_test() { - $STACK --no-terminal test --only-snapshot -} - -test() { - $STACK --no-terminal test --pedantic -} - -test_docs() { - $STACK --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs - $STACK --no-terminal haddock --no-haddock-deps -} - -setup_lint() { - $STACK --no-terminal install hlint -} - -lint() { - $STACK --no-terminal exec hlint -- src tests -} - -$1 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 961253f..9fce1d3 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -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) + ] diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index aba6dfd..3d368d4 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs deleted file mode 100644 index 0fe3e03..0000000 --- a/src/Language/GraphQL/AST/Core.hs +++ /dev/null @@ -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 - diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 430e92a..3394bfa 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -19,6 +19,7 @@ module Language.GraphQL.AST.Document , FragmentDefinition(..) , ImplementsInterfaces(..) , InputValueDefinition(..) + , Location(..) , Name , NamedType , NonNullType(..) @@ -55,6 +56,12 @@ import Language.GraphQL.AST.DirectiveLocation -- | 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 @@ type Document = NonEmpty Definition -- | 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 @@ data OperationDefinition -- * 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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 7fb0677..a0dac5b 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 @@ document formatter defs | 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 @@ definition formatter x -- | 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 @@ stringValue (Pretty indentation) string = 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' diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index 0ba55e3..17d3f9c 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -168,11 +168,11 @@ blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer -- | 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 @@ -233,4 +233,4 @@ extend token extensionLabel parsers tryExtension extensionParser = try $ symbol "extend" *> symbol token - *> extensionParser
\ No newline at end of file + *> extensionParser diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index c18c36a..687d8f5 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -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,19 +20,47 @@ import Language.GraphQL.AST.DirectiveLocation ) 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 @@ -40,19 +69,22 @@ executableDefinition = DefinitionOperation <$> operationDefinition 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 @@ directiveDefinition = DirectiveDefinition 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 @@ executableDirectiveLocation = Directive.Query <$ symbol "QUERY" <|> 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 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" <|> Directive.EnumValue <$ symbol "ENUM_VALUE" <|> Directive.InputObject <$ symbol "INPUT_OBJECT" <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION" - -typeDefinition :: Parser TypeDefinition -typeDefinition = scalarTypeDefinition - <|> objectTypeDefinition - <|> interfaceTypeDefinition - <|> unionTypeDefinition - <|> enumTypeDefinition - <|> inputObjectTypeDefinition + <?> "TypeSystemDirectiveLocation" + +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 @@ typeExtension = scalarTypeExtension <|> 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 :: Parser TypeExtension 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 @@ objectTypeExtension = extend "type" "ObjectTypeExtension" 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 @@ unionMemberTypes sepBy' = UnionMemberTypes <*> 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 @@ interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" <$> 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 @@ enumTypeExtension = extend "enum" "EnumTypeExtension" <$> 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 @@ operationTypeDefinition = OperationTypeDefinition operationDefinition :: Parser OperationDefinition operationDefinition = SelectionSet <$> selectionSet <|> operationDefinition' - <?> "operationDefinition error" + <?> "OperationDefinition" where operationDefinition' = OperationDefinition <$> operationType @@ -333,23 +363,20 @@ operationDefinition = SelectionSet <$> selectionSet 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 @@ field = Field <*> 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 @@ inlineFragment = InlineFragment <*> 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 = VariableDefinition <?> "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 @@ type' = try (TypeNonNull <$> nonNullType) 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 diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 59719b0..9df69de 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -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 @@ import Text.Megaparsec -- | 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 diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 45bace0..2b615f4 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 0c10419..d8d5b13 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -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.HashMap.Strict as HashMap 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 @@ instanceOf objectType (AbstractUnionType unionType) = 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 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = 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 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result 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 @@ completeValue (Out.UnionBaseType unionType) fields result 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) diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs new file mode 100644 index 0000000..0bd274f --- /dev/null +++ b/src/Language/GraphQL/Execute/Subscribe.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 733ac8c..76d1fe7 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -44,12 +44,11 @@ import Data.Text (Text) 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 Selection m 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 @@ document schema operationName subs ast = do | 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 @@ defragment ast = 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 @@ operation operationDefinition replacement 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 @@ selection (Full.Field alias name arguments' directives' selections) = 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.Field alias name arguments' directives' selections) = 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 @@ selection (Full.FragmentSpread name directives') = _ -> 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 @@ appendSelection = foldM go mempty 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' diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs deleted file mode 100644 index fa7718a..0000000 --- a/src/Language/GraphQL/Trans.hs +++ /dev/null @@ -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 diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index 5dfd622..e84fc03 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 1379018..476fb3a 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -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 @@ module Language.GraphQL.Type.Definition , 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 @@ instance IsString Value where -- 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 @@ id = ScalarType "ID" (Just description) \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' diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs deleted file mode 100644 index 017132c..0000000 --- a/src/Language/GraphQL/Type/Directive.hs +++ /dev/null @@ -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' diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs new file mode 100644 index 0000000..9121d13 --- /dev/null +++ b/src/Language/GraphQL/Type/Internal.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 856c4f8..89bbf1d 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -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 @@ module Language.GraphQL.Type.Out , 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 (NonNullInterfaceType _) = True 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 diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 4d7b9eb..c5cc6fd 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -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 @@ data Type m | 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 AbstractType m 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 diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs new file mode 100644 index 0000000..5768615 --- /dev/null +++ b/src/Language/GraphQL/Validate.hs @@ -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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs new file mode 100644 index 0000000..a3314e7 --- /dev/null +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -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." diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs new file mode 100644 index 0000000..093685b --- /dev/null +++ b/src/Test/Hspec/GraphQL.hs @@ -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" @@ -1,4 +1,4 @@ -resolver: lts-16.1 +resolver: lts-16.6 packages: - . diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 2801b57..f59e5a9 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -129,10 +129,11 @@ spec = describe "Parser" $ do 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 :| []) @@ -149,3 +150,22 @@ spec = describe "Parser" $ do 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 + } + } + |] diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs index 8bb39ed..482dc3a 100644 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -4,6 +4,7 @@ module Language.GraphQL.ErrorSpec ) 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 @@ import Test.Hspec ( Spec 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 diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 30568be..8fbb55b 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -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.Error 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 diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs new file mode 100644 index 0000000..f84322d --- /dev/null +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -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 diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index b147d77..e6b6cea 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 qualified Data.HashMap.Strict as HashMap 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 @@ spec = |] 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 @@ spec = 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 @@ spec = |] 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 @@ spec = |] 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 @@ spec = |] actual <- graphql experimentalResolver sourceQuery - actual `shouldBe` emptyObject + actual `shouldResolveTo` emptyObject diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 2924e63..089b721 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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 @@ inlineQuery = [r|{ } }|] -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 @@ toSchema t (_, resolve) = Schema "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 @@ spec = do 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 @@ spec = do 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 @@ spec = do 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 @@ spec = do |] 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 @@ spec = do |] 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 @@ spec = do |] actual <- graphql (toSchema "circumference" circumference) sourceQuery - actual `shouldBe` expected + actual `shouldResolveTo` expected it "considers type condition" $ do let sourceQuery = [r| @@ -223,12 +213,11 @@ spec = do 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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 0e534fc..ea89279 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 @@ module Test.RootOperationSpec 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 @@ spec = } } |] - 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 @@ spec = incrementCircumference } |] - expected = object - [ "data" .= object + expected = HashMap.singleton "data" + $ object [ "incrementCircumference" .= (61 :: Int) ] - ] actual <- graphql schema querySource - actual `shouldBe` expected + actual `shouldResolveTo` expected diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 427371b..e3dd696 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Test.StarWars.Data ( Character + , StarWarsException(..) , appearsIn , artoo , getDroid @@ -16,12 +17,13 @@ module Test.StarWars.Data , 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,8 +68,20 @@ appearsIn :: Character -> [Int] 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 :: Int -> Character 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' "1003" = pure leia 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 diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index cf451f8..95b18d3 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -6,7 +6,6 @@ module Test.StarWars.QuerySpec 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 @@ spec = describe "Star Wars Query Tests" $ do 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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 5fcdf3e..cecd8eb 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -4,14 +4,11 @@ module Test.StarWars.Schema ( 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 @@ import Prelude hiding (id) -- 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 - -idFieldType :: Out.Field Identity -idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty - -nameFieldType :: Out.Field Identity -nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty - -friendsFieldType :: Out.Field Identity -friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty + primaryFunctionFieldType + = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty) + $ idField "primaryFunction" + +typenameFieldType :: Resolver (Either SomeException) +typenameFieldType + = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty) + $ idField "__typename" + +idFieldType :: Resolver (Either SomeException) +idFieldType + = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty) + $ idField "id" + +nameFieldType :: Resolver (Either SomeException) +nameFieldType + = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty) + $ idField "name" + +friendsFieldType :: Resolver (Either SomeException) +friendsFieldType + = ValueResolver (Out.Field Nothing fieldType mempty) + $ idField "friends" + where + fieldType = Out.ListType $ Out.NamedObjectType droidObject -appearsInField :: Out.Field Identity -appearsInField = Out.Field (Just description) fieldType mempty +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 @@ episodeEnum = EnumType "Episode" (Just description) 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 @@ hero = do 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." - -droid :: ActionT Identity Value + String i -> pure $ maybe Null character $ getHuman i >>= Just + _ -> throwM InvalidArguments + +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 |