diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,62 @@ -# Change Log +# Changelog All notable changes to this project will be documented in this file. +The format is based on +[Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [Unreleased] + +## [0.7.0.0] - 2020-05-11 +### Fixed +- Result of null encoding +- Block strings encoding +- Result of tab and newline encoding + +### Added +- AST for the GraphQL schema. +- Type system definition parser. +- `Trans.argument`. +- Schema extension parser. +- Contributing guidelines. +- `Schema.resolversToMap` (intended for to be used internally). + +### Changed +- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`. + `AST.Document.TypeSystemDefinition` and `AST.Document.TypeSystemExtension` + can also be definitions. +- Move all AST data to `AST.Document` and reexport them. +- Rename `AST.OperationSelectionSet` to `AST.Document.SelectionSet`. +- Make `Schema.Subs` a `Data.HashMap.Strict` (was a function + `key -> Maybe value` before). +- Make `AST.Lexer.at` a text (symbol) parser. It was a char before and is + `symbol "@"` now. +- Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO, + set the inner monad to `Identity`. +- `NonEmpty (Resolver m)` is now `HashMap Text (NonEmpty (Resolver m))`. Root + operation type can be any type, therefore a hashmap is needed. Since types + cannot be empty, we save the list of resolvers in the type as a non-empty + list. Currently only "Query" and "Mutation" are supported as types. For more + schema support is required. The executor checks now if the type in the query + matches the type of the provided root resolvers. + +### Removed +- `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`. + These types are only used in `AST.Selection` and `AST.Selection` contains now + 3 corresponding data constructors, `Field`, `InlineFragment` and + `FragmentSpread`, instead of separate types. It simplifies pattern matching + and doesn't make the code less typesafe. +- `Schema.scalarA`. +- `Schema.wrappedScalarA`. +- `Schema.wrappedObjectA`. +- `Schema.objectA`. +- `AST.Argument`. Replaced with `AST.Arguments` which holds all arguments as a + key/value map. + ## [0.6.1.0] - 2019-12-23 ### Fixed -- Parsing multiple string arguments, such as +- Parsing multiple string arguments, such as `login(username: "username", password: "password")` would fail on the comma due to strings not having a space consumer. - Fragment spread is evaluated based on the `__typename` resolver. If the @@ -162,6 +215,8 @@ ### Added - Data types for the GraphQL language. +[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD +[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 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0 [0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2019 Eugen Wissner, Germany +Copyright 2019-2020 Eugen Wissner, Germany Copyright 2015-2017 J. Daniel Navarro All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,10 +24,17 @@ ## Documentation API documentation is available through -[hackage](https://hackage.haskell.org/package/graphql). +[Hackage](https://hackage.haskell.org/package/graphql). You'll also find a small tutorial with some examples under [docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial). + +## Further information + +- [Contributing guidelines](CONTRIBUTING.md). +- [Changelog](CHANGELOG.md) – this one contains the most recent changes; + individual changelogs for specific versions can be found on + [Hackage](https://hackage.haskell.org/package/graphql). ## Contact diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -12,20 +12,19 @@ Since this file is a literate haskell file, we start by importing some dependencies. > {-# LANGUAGE OverloadedStrings #-} -> {-# LANGUAGE LambdaCase #-} > module Main where > > import Control.Monad.IO.Class (liftIO) -> import Control.Monad.Trans.Except (throwE) > import Data.Aeson (encode) > import Data.ByteString.Lazy.Char8 (putStrLn) +> import Data.HashMap.Strict (HashMap) +> import qualified Data.HashMap.Strict as HashMap > import Data.List.NonEmpty (NonEmpty(..)) > import Data.Text (Text) > import Data.Time (getCurrentTime) > > import Language.GraphQL > import qualified Language.GraphQL.Schema as Schema -> import Language.GraphQL.Trans (ActionT(..)) > > import Prelude hiding (putStrLn) @@ -36,8 +35,8 @@ First we build a GraphQL schema. -> schema1 :: NonEmpty (Schema.Resolver IO) -> schema1 = hello :| [] +> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO)) +> schema1 = HashMap.singleton "Query" $ hello :| [] > > hello :: Schema.Resolver IO > hello = Schema.scalar "hello" (return ("it's me" :: Text)) @@ -66,14 +65,13 @@ For this example, we're going to be using time. -> schema2 :: NonEmpty (Schema.Resolver IO) -> schema2 = time :| [] +> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO)) +> schema2 = HashMap.singleton "Query" $ time :| [] > > time :: Schema.Resolver IO -> time = Schema.scalarA "time" $ \case -> [] -> do t <- liftIO getCurrentTime -> return $ show t -> _ -> ActionT $ throwE "Invalid arguments." +> time = Schema.scalar "time" $ do +> t <- liftIO getCurrentTime +> return $ show t This defines a simple schema with one type and one field, which resolves to the current time. @@ -126,8 +124,8 @@ Now that we have two resolvers, we can define a schema which uses them both. -> schema3 :: NonEmpty (Schema.Resolver IO) -> schema3 = hello :| [time] +> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO)) +> schema3 = HashMap.singleton "Query" $ hello :| [time] > > query3 :: Text > query3 = "query timeAndHello { time hello }" diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -1,9 +1,9 @@ cabal-version: 1.12 name: graphql -version: 0.6.1.0 +version: 0.7.0.0 license: BSD3 license-file: LICENSE -copyright: (c) 2019 Eugen Wissner, +copyright: (c) 2019-2020 Eugen Wissner, (c) 2015-2017 J. Daniel Navarro maintainer: belka@caraus.de author: Danny Navarro , @@ -34,6 +34,8 @@ Language.GraphQL Language.GraphQL.AST Language.GraphQL.AST.Core + Language.GraphQL.AST.DirectiveLocation + Language.GraphQL.AST.Document Language.GraphQL.AST.Encoder Language.GraphQL.AST.Lexer Language.GraphQL.AST.Parser @@ -48,11 +50,12 @@ Language.GraphQL.Type.Directive default-language: Haskell2010 build-depends: - aeson >=1.4.6.0 && <1.5, + aeson >=1.4.7.1 && <1.5, base >=4.7 && <5, - containers >=0.6.0.1 && <0.7, - megaparsec >=7.0.5 && <7.1, - text >=1.2.3.1 && <1.3, + containers >=0.6.2.1 && <0.7, + megaparsec >=8.0.0 && <8.1, + parser-combinators >=1.2.1 && <1.3, + text >=1.2.4.0 && <1.3, transformers >=0.5.6.2 && <0.6, unordered-containers >=0.2.10.0 && <0.3 @@ -75,15 +78,17 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4.6.0 && <1.5, + QuickCheck >=2.13.2 && <2.14, + aeson >=1.4.7.1 && <1.5, base >=4.7 && <5, - containers >=0.6.0.1 && <0.7, + containers >=0.6.2.1 && <0.7, graphql -any, hspec >=2.7.1 && <2.8, hspec-expectations >=0.8.2 && <0.9, - hspec-megaparsec >=2.0.1 && <2.1, - megaparsec >=7.0.5 && <7.1, + hspec-megaparsec >=2.1.0 && <2.2, + megaparsec >=8.0.0 && <8.1, + parser-combinators >=1.2.1 && <1.3, raw-strings-qq ==1.1.*, - text >=1.2.3.1 && <1.3, + text >=1.2.4.0 && <1.3, transformers >=0.5.6.2 && <0.6, unordered-containers >=0.2.10.0 && <0.3 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -4,10 +4,10 @@ , graphqlSubs ) where -import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson import Data.List.NonEmpty (NonEmpty) -import qualified Data.Text as T +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) import Language.GraphQL.Error import Language.GraphQL.Execute import Language.GraphQL.AST.Parser @@ -16,19 +16,19 @@ -- | If the text parses correctly as a @GraphQL@ query the query is -- executed using the given 'Schema.Resolver's. -graphql :: MonadIO m - => NonEmpty (Schema.Resolver m) -- ^ Resolvers. - -> T.Text -- ^ Text representing a @GraphQL@ request document. +graphql :: Monad m + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. + -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. -graphql = flip graphqlSubs $ const Nothing +graphql = flip graphqlSubs 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.Resolver's. -graphqlSubs :: MonadIO m - => NonEmpty (Schema.Resolver m) -- ^ Resolvers. +graphqlSubs :: Monad m + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. - -> T.Text -- ^ Text representing a @GraphQL@ request document. + -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. graphqlSubs schema f = either parseError (execute schema f) diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -1,185 +1,6 @@ --- | This module defines an abstract syntax tree for the @GraphQL@ language based on --- . --- --- Target AST for Parser. +-- | Target AST for Parser. module Language.GraphQL.AST - ( Alias - , Argument(..) - , Definition(..) - , Directive(..) - , Document - , Field(..) - , FragmentDefinition(..) - , FragmentSpread(..) - , InlineFragment(..) - , Name - , NonNullType(..) - , ObjectField(..) - , OperationDefinition(..) - , OperationType(..) - , Selection(..) - , SelectionSet - , SelectionSetOpt - , Type(..) - , TypeCondition - , Value(..) - , VariableDefinition(..) + ( module Language.GraphQL.AST.Document ) where -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) - --- * Document - --- | GraphQL document. -type Document = NonEmpty Definition - --- | Name -type Name = Text - --- | Directive. -data Directive = Directive Name [Argument] deriving (Eq, Show) - --- * Operations - --- | Top-level definition of a document, either an operation or a fragment. -data Definition - = DefinitionOperation OperationDefinition - | DefinitionFragment FragmentDefinition - deriving (Eq, Show) - --- | Operation definition. -data OperationDefinition - = OperationSelectionSet SelectionSet - | OperationDefinition OperationType - (Maybe Name) - [VariableDefinition] - [Directive] - SelectionSet - deriving (Eq, Show) - --- | GraphQL has 3 operation types: queries, mutations and subscribtions. --- --- Currently only queries and mutations are supported. -data OperationType = Query | Mutation deriving (Eq, Show) - --- * Selections - --- | "Top-level" selection, selection on an operation or fragment. -type SelectionSet = NonEmpty Selection - --- | Field selection. -type SelectionSetOpt = [Selection] - --- | Single selection element. -data Selection - = SelectionField Field - | SelectionFragmentSpread FragmentSpread - | SelectionInlineFragment InlineFragment - deriving (Eq, Show) - --- * Field - --- | Single GraphQL field. --- --- The only required property of a field is its name. Optionally it can also --- have an alias, arguments or a list of subfields. --- --- Given the following query: --- --- @ --- { --- zuck: user(id: 4) { --- id --- name --- } --- } --- @ --- --- * "user", "id" and "name" are field names. --- * "user" has two subfields, "id" and "name". --- * "zuck" is an alias for "user". "id" and "name" have no aliases. --- * "id: 4" is an argument for "user". "id" and "name" don't have any --- arguments. -data Field - = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt - deriving (Eq, Show) - --- | Alternative field name. --- --- @ --- { --- smallPic: profilePic(size: 64) --- bigPic: profilePic(size: 1024) --- } --- @ --- --- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic", --- used to distinquish between profile pictures with different arguments --- (sizes). -type Alias = Name - --- | Single argument. --- --- @ --- { --- user(id: 4) { --- name --- } --- } --- @ --- --- Here "id" is an argument for the field "user" and its value is 4. -data Argument = Argument Name Value deriving (Eq,Show) - --- * Fragments - --- | Fragment spread. -data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show) - --- | Inline fragment. -data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet - deriving (Eq, Show) - --- | Fragment definition. -data FragmentDefinition - = FragmentDefinition Name TypeCondition [Directive] SelectionSet - deriving (Eq, Show) - --- * Inputs - --- | Input value. -data Value = Variable Name - | Int Int32 - | Float Double - | String Text - | Boolean Bool - | Null - | Enum Name - | List [Value] - | Object [ObjectField] - deriving (Eq, Show) - --- | Key-value pair. --- --- A list of 'ObjectField's represents a GraphQL object type. -data ObjectField = ObjectField Name Value deriving (Eq, Show) - --- | Variable definition. -data VariableDefinition = VariableDefinition Name Type (Maybe Value) - deriving (Eq, Show) - --- | Type condition. -type TypeCondition = Name - --- | Type representation. -data Type = TypeNamed Name - | TypeList Type - | TypeNonNull NonNullType - deriving (Eq, Show) - --- | Helper type to represent Non-Null types and lists of such types. -data NonNullType = NonNullTypeNamed Name - | NonNullTypeList Type - deriving (Eq, Show) +import Language.GraphQL.AST.Document diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -1,7 +1,6 @@ -- | This is the AST meant to be executed. module Language.GraphQL.AST.Core ( Alias - , Argument(..) , Arguments(..) , Directive(..) , Document @@ -35,15 +34,18 @@ -- | Single GraphQL field. data Field - = Field (Maybe Alias) Name [Argument] (Seq Selection) + = Field (Maybe Alias) Name Arguments (Seq Selection) deriving (Eq, Show) --- | Single argument. -data Argument = Argument Name Value deriving (Eq, Show) - -- | 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 -- | Directive. data Directive = Directive Name Arguments diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -0,0 +1,41 @@ +-- | Various parts of a GraphQL document can be annotated with directives. +-- This module describes locations in a document where directives can appear. +module Language.GraphQL.AST.DirectiveLocation + ( DirectiveLocation(..) + , ExecutableDirectiveLocation(..) + , TypeSystemDirectiveLocation(..) + ) where + +-- | All directives can be splitted in two groups: directives used to annotate +-- various parts of executable definitions and the ones used in the schema +-- definition. +data DirectiveLocation + = ExecutableDirectiveLocation ExecutableDirectiveLocation + | TypeSystemDirectiveLocation TypeSystemDirectiveLocation + deriving (Eq, Show) + +-- | Where directives can appear in an executable definition, like a query. +data ExecutableDirectiveLocation + = Query + | Mutation + | Subscription + | Field + | FragmentDefinition + | FragmentSpread + | InlineFragment + deriving (Eq, Show) + +-- | Where directives can appear in a type system definition. +data TypeSystemDirectiveLocation + = Schema + | Scalar + | Object + | FieldDefinition + | ArgumentDefinition + | Interface + | Union + | Enum + | EnumValue + | InputObject + | InputFieldDefinition + deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/AST/Document.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module defines an abstract syntax tree for the @GraphQL@ language. It +-- follows closely the structure given in the specification. Please refer to +-- . +-- for more information. +module Language.GraphQL.AST.Document + ( Alias + , Argument(..) + , ArgumentsDefinition(..) + , Definition(..) + , Description(..) + , Directive(..) + , Document + , EnumValueDefinition(..) + , ExecutableDefinition(..) + , FieldDefinition(..) + , FragmentDefinition(..) + , ImplementsInterfaces(..) + , InputValueDefinition(..) + , Name + , NamedType + , NonNullType(..) + , ObjectField(..) + , OperationDefinition(..) + , OperationType(..) + , OperationTypeDefinition(..) + , SchemaExtension(..) + , Selection(..) + , SelectionSet + , SelectionSetOpt + , Type(..) + , TypeCondition + , TypeDefinition(..) + , TypeExtension(..) + , TypeSystemDefinition(..) + , TypeSystemExtension(..) + , UnionMemberTypes(..) + , Value(..) + , VariableDefinition(..) + ) where + +import Data.Foldable (toList) +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import qualified Data.Text as Text +import Language.GraphQL.AST.DirectiveLocation + +-- * Language + +-- ** Source Text + +-- | Name. +type Name = Text + +-- ** Document + +-- | GraphQL document. +type Document = NonEmpty Definition + +-- | All kinds of definitions that can occur in a GraphQL document. +data Definition + = ExecutableDefinition ExecutableDefinition + | TypeSystemDefinition TypeSystemDefinition + | TypeSystemExtension TypeSystemExtension + deriving (Eq, Show) + +-- | Top-level definition of a document, either an operation or a fragment. +data ExecutableDefinition + = DefinitionOperation OperationDefinition + | DefinitionFragment FragmentDefinition + deriving (Eq, Show) + +-- ** Operations + +-- | Operation definition. +data OperationDefinition + = SelectionSet SelectionSet + | OperationDefinition + OperationType + (Maybe Name) + [VariableDefinition] + [Directive] + SelectionSet + deriving (Eq, Show) + +-- | GraphQL has 3 operation types: +-- +-- * query - a read-only fetch. +-- * 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) + +-- ** Selection Sets + +-- | "Top-level" selection, selection on an operation or fragment. +type SelectionSet = NonEmpty Selection + +-- | Field selection. +type SelectionSetOpt = [Selection] + +-- | Selection is a single entry in a selection set. It can be a single field, +-- fragment spread or inline fragment. +-- +-- The only required property of a field is its name. Optionally it can also +-- have an alias, arguments, directives and a list of subfields. +-- +-- In the following query "user" is a field with two subfields, "id" and "name": +-- +-- @ +-- { +-- user { +-- id +-- name +-- } +-- } +-- @ +-- +-- A fragment spread refers to a fragment defined outside the operation and is +-- expanded at the execution time. +-- +-- @ +-- { +-- user { +-- ...userFragment +-- } +-- } +-- +-- fragment userFragment on UserType { +-- id +-- name +-- } +-- @ +-- +-- Inline fragments are similar but they don't have any name and the type +-- condition ("on UserType") is optional. +-- +-- @ +-- { +-- user { +-- ... on UserType { +-- id +-- name +-- } +-- } +-- @ +data Selection + = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt + | FragmentSpread Name [Directive] + | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet + deriving (Eq, Show) + +-- ** Arguments + +-- | Single argument. +-- +-- @ +-- { +-- user(id: 4) { +-- name +-- } +-- } +-- @ +-- +-- Here "id" is an argument for the field "user" and its value is 4. +data Argument = Argument Name Value deriving (Eq,Show) + +-- ** Field Alias + +-- | Alternative field name. +-- +-- @ +-- { +-- smallPic: profilePic(size: 64) +-- bigPic: profilePic(size: 1024) +-- } +-- @ +-- +-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic", +-- used to distinquish between profile pictures with different arguments +-- (sizes). +type Alias = Name + +-- ** Fragments + +-- | Fragment definition. +data FragmentDefinition + = FragmentDefinition Name TypeCondition [Directive] SelectionSet + deriving (Eq, Show) + +-- | Type condition. +type TypeCondition = Name + +-- ** Input Values + +-- | Input value. +data Value + = Variable Name + | Int Int32 + | Float Double + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] + | Object [ObjectField] + deriving (Eq, Show) + +-- | Key-value pair. +-- +-- A list of 'ObjectField's represents a GraphQL object type. +data ObjectField = ObjectField Name Value deriving (Eq, Show) + +-- ** Variables + +-- | Variable definition. +data VariableDefinition = VariableDefinition Name Type (Maybe Value) + deriving (Eq, Show) + +-- ** Type References + +-- | Type representation. +data Type + = TypeNamed Name + | TypeList Type + | TypeNonNull NonNullType + deriving (Eq, Show) + +-- | Represents type names. +type NamedType = Name + +-- | Helper type to represent Non-Null types and lists of such types. +data NonNullType + = NonNullTypeNamed Name + | NonNullTypeList Type + deriving (Eq, Show) + +-- ** Directives + +-- | Directive. +-- +-- Directives begin with "@", can accept arguments, and can be applied to the +-- most GraphQL elements, providing additional information. +data Directive = Directive Name [Argument] deriving (Eq, Show) + +-- * Type System + +-- | Type system can define a schema, a type or a directive. +-- +-- @ +-- schema { +-- query: Query +-- } +-- +-- directive @example on FIELD_DEFINITION +-- +-- type Query { +-- field: String @example +-- } +-- @ +-- +-- This example defines a custom directive "@example", which is applied to a +-- field definition of the type definition "Query". On the top the schema +-- is defined by taking advantage of the type "Query". +data TypeSystemDefinition + = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition) + | TypeDefinition TypeDefinition + | DirectiveDefinition + Description Name ArgumentsDefinition (NonEmpty DirectiveLocation) + deriving (Eq, Show) + +-- ** Type System Extensions + +-- | Extension for a type system definition. Only schema and type definitions +-- can be extended. +data TypeSystemExtension + = SchemaExtension SchemaExtension + | TypeExtension TypeExtension + deriving (Eq, Show) + +-- ** Schema + +-- | Root operation type definition. +-- +-- Defining root operation types is not required since they have defaults. So +-- the default query root type is "Query", and the default mutation root type +-- is "Mutation". But these defaults can be changed for a specific schema. In +-- the following code the query root type is changed to "MyQueryRootType", and +-- the mutation root type to "MyMutationRootType": +-- +-- @ +-- schema { +-- query: MyQueryRootType +-- mutation: MyMutationRootType +-- } +-- @ +data OperationTypeDefinition + = OperationTypeDefinition OperationType NamedType + deriving (Eq, Show) + +-- | Extension of the schema definition by further operations or directives. +data SchemaExtension + = SchemaOperationExtension [Directive] (NonEmpty OperationTypeDefinition) + | SchemaDirectivesExtension (NonEmpty Directive) + deriving (Eq, Show) + +-- ** Descriptions + +-- | GraphQL has built-in capability to document service APIs. Documentation +-- is a GraphQL string that precedes a particular definition and contains +-- Markdown. Any GraphQL definition can be documented this way. +-- +-- @ +-- """ +-- Supported languages. +-- """ +-- enum Language { +-- "English" +-- EN +-- +-- "Russian" +-- RU +-- } +-- @ +newtype Description = Description (Maybe Text) + deriving (Eq, Show) + +-- ** Types + +-- | Type definitions describe various user-defined types. +data TypeDefinition + = ScalarTypeDefinition Description Name [Directive] + | ObjectTypeDefinition + Description + Name + (ImplementsInterfaces []) + [Directive] + [FieldDefinition] + | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition] + | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes []) + | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition] + | InputObjectTypeDefinition + Description Name [Directive] [InputValueDefinition] + deriving (Eq, Show) + +-- | Extensions for custom, already defined types. +data TypeExtension + = ScalarTypeExtension Name (NonEmpty Directive) + | ObjectTypeFieldsDefinitionExtension + Name (ImplementsInterfaces []) [Directive] (NonEmpty FieldDefinition) + | ObjectTypeDirectivesExtension + Name (ImplementsInterfaces []) (NonEmpty Directive) + | ObjectTypeImplementsInterfacesExtension + Name (ImplementsInterfaces NonEmpty) + | InterfaceTypeFieldsDefinitionExtension + Name [Directive] (NonEmpty FieldDefinition) + | InterfaceTypeDirectivesExtension Name (NonEmpty Directive) + | UnionTypeUnionMemberTypesExtension + Name [Directive] (UnionMemberTypes NonEmpty) + | UnionTypeDirectivesExtension Name (NonEmpty Directive) + | EnumTypeEnumValuesDefinitionExtension + Name [Directive] (NonEmpty EnumValueDefinition) + | EnumTypeDirectivesExtension Name (NonEmpty Directive) + | InputObjectTypeInputFieldsDefinitionExtension + Name [Directive] (NonEmpty InputValueDefinition) + | InputObjectTypeDirectivesExtension Name (NonEmpty Directive) + deriving (Eq, Show) + +-- ** Objects + +-- | Defines a list of interfaces implemented by the given object type. +-- +-- @ +-- type Business implements NamedEntity & ValuedEntity { +-- name: String +-- } +-- @ +-- +-- Here the object type "Business" implements two interfaces: "NamedEntity" and +-- "ValuedEntity". +newtype ImplementsInterfaces t = ImplementsInterfaces (t NamedType) + +instance Foldable t => Eq (ImplementsInterfaces t) where + (ImplementsInterfaces xs) == (ImplementsInterfaces ys) + = toList xs == toList ys + +instance Foldable t => Show (ImplementsInterfaces t) where + show (ImplementsInterfaces interfaces) = Text.unpack + $ Text.append "implements" + $ Text.intercalate " & " + $ toList interfaces + +-- | Definition of a single field in a type. +-- +-- @ +-- type Person { +-- name: String +-- picture(width: Int, height: Int): Url +-- } +-- @ +-- +-- "name" and "picture", including their arguments and types, are field +-- definitions. +data FieldDefinition + = FieldDefinition Description Name ArgumentsDefinition Type [Directive] + deriving (Eq, Show) + +-- | A list of values passed to a field. +-- +-- @ +-- type Person { +-- name: String +-- picture(width: Int, height: Int): Url +-- } +-- @ +-- +-- "Person" has two fields, "name" and "picture". "name" doesn't have any +-- arguments, so 'ArgumentsDefinition' contains an empty list. "picture" +-- contains definitions for 2 arguments: "width" and "height". +newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition] + deriving (Eq, Show) + +instance Semigroup ArgumentsDefinition where + (ArgumentsDefinition xs) <> (ArgumentsDefinition ys) = + ArgumentsDefinition $ xs <> ys + +instance Monoid ArgumentsDefinition where + mempty = ArgumentsDefinition [] + +-- | Defines an input value. +-- +-- * Input values can define field arguments, see 'ArgumentsDefinition'. +-- * They can also be used as field definitions in an input type. +-- +-- @ +-- input Point2D { +-- x: Float +-- y: Float +-- } +-- @ +-- +-- The input type "Point2D" contains two value definitions: "x" and "y". +data InputValueDefinition + = InputValueDefinition Description Name Type (Maybe Value) [Directive] + deriving (Eq, Show) + +-- ** Unions + +-- | List of types forming a union. +-- +-- @ +-- union SearchResult = Person | Photo +-- @ +-- +-- "Person" and "Photo" are member types of the union "SearchResult". +newtype UnionMemberTypes t = UnionMemberTypes (t NamedType) + +instance Foldable t => Eq (UnionMemberTypes t) where + (UnionMemberTypes xs) == (UnionMemberTypes ys) = toList xs == toList ys + +instance Foldable t => Show (UnionMemberTypes t) where + show (UnionMemberTypes memberTypes) = Text.unpack + $ Text.intercalate " | " + $ toList memberTypes + +-- ** Enums + +-- | Single value in an enum definition. +-- +-- @ +-- enum Direction { +-- NORTH +-- EAST +-- SOUTH +-- WEST +-- } +-- @ +-- +-- "NORTH, "EAST", "SOUTH", and "WEST" are value definitions of an enum type +-- definition "Direction". +data EnumValueDefinition = EnumValueDefinition Description Name [Directive] + deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -15,7 +15,6 @@ import Data.Char (ord) import Data.Foldable (fold) -import Data.Monoid ((<>)) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text @@ -26,6 +25,7 @@ import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) import qualified Language.GraphQL.AST as Full +import Language.GraphQL.AST.Document -- | Instructs the encoder whether the GraphQL document should be minified or -- pretty printed. @@ -43,16 +43,18 @@ minified :: Formatter minified = Minified --- | Converts a 'Full.Document' into a string. -document :: Formatter -> Full.Document -> Lazy.Text +-- | Converts a Document' into a string. +document :: Formatter -> Document -> Lazy.Text document formatter defs | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where - encodeDocument = NonEmpty.toList $ definition formatter <$> defs + encodeDocument = foldr executableDefinition [] defs + executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc + executableDefinition _ acc = acc --- | Converts a 'Full.Definition' into a string. -definition :: Formatter -> Full.Definition -> Lazy.Text +-- | Converts a t'Full.ExecutableDefinition' into a string. +definition :: Formatter -> ExecutableDefinition -> Lazy.Text definition formatter x | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x @@ -62,14 +64,16 @@ encodeDefinition (Full.DefinitionFragment fragment) = fragmentDefinition formatter fragment +-- | Converts a 'Full.OperationDefinition into a string. operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text -operationDefinition formatter (Full.OperationSelectionSet sels) +operationDefinition formatter (Full.SelectionSet sels) = selectionSet formatter sels operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels) = "query " <> node formatter name vars dirs sels operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels) = "mutation " <> node formatter name vars dirs sels +-- | Converts a Full.Query or Full.Mutation into a string. node :: Formatter -> Maybe Full.Name -> [Full.VariableDefinition] -> @@ -110,17 +114,21 @@ selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter +indentSymbol :: Lazy.Text +indentSymbol = " " + indent :: (Integral a) => a -> Lazy.Text -indent indentation = Lazy.Text.replicate (fromIntegral indentation) " " +indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol selection :: Formatter -> Full.Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection where - encodeSelection (Full.SelectionField field') = field incrementIndent field' - encodeSelection (Full.SelectionInlineFragment fragment) = - inlineFragment incrementIndent fragment - encodeSelection (Full.SelectionFragmentSpread spread) = - fragmentSpread incrementIndent spread + encodeSelection (Full.Field alias name args directives' selections) = + field incrementIndent alias name args directives' selections + encodeSelection (Full.InlineFragment typeCondition directives' selections) = + inlineFragment incrementIndent typeCondition directives' selections + encodeSelection (Full.FragmentSpread name directives') = + fragmentSpread incrementIndent name directives' incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 | otherwise = Minified @@ -131,8 +139,15 @@ colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" -field :: Formatter -> Full.Field -> Lazy.Text -field formatter (Full.Field alias name args dirs set) +-- | Converts Full.Field into a string +field :: Formatter -> + Maybe Full.Name -> + Full.Name -> + [Full.Argument] -> + [Full.Directive] -> + [Full.Selection] -> + Lazy.Text +field formatter alias name args dirs set = optempty prependAlias (fold alias) <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args @@ -154,13 +169,18 @@ -- * Fragments -fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text -fragmentSpread formatter (Full.FragmentSpread name ds) - = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds +fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text +fragmentSpread formatter name directives' + = "..." <> Lazy.Text.fromStrict name + <> optempty (directives formatter) directives' -inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text -inlineFragment formatter (Full.InlineFragment tc dirs sels) - = "... on " +inlineFragment :: + Formatter -> + Maybe Full.TypeCondition -> + [Full.Directive] -> + Full.SelectionSet -> + Lazy.Text +inlineFragment formatter tc dirs sels = "... on " <> Lazy.Text.fromStrict (fold tc) <> directives formatter dirs <> eitherFormat formatter " " mempty @@ -191,7 +211,7 @@ value _ (Full.Int x) = Builder.toLazyText $ decimal x value _ (Full.Float x) = Builder.toLazyText $ realFloat x value _ (Full.Boolean x) = booleanValue x -value _ Full.Null = mempty +value _ Full.Null = "null" value formatter (Full.String string) = stringValue formatter string value _ (Full.Enum x) = Lazy.Text.fromStrict x value formatter (Full.List x) = listValue formatter x @@ -201,34 +221,50 @@ booleanValue True = "true" booleanValue False = "false" +quote :: Builder.Builder +quote = Builder.singleton '\"' + +oneLine :: Text -> Builder +oneLine string = quote <> Text.foldr (mappend . escape) quote string + stringValue :: Formatter -> Text -> Lazy.Text stringValue Minified string = Builder.toLazyText - $ quote <> Text.foldr (mappend . escape') quote string - where - quote = Builder.singleton '\"' - escape' '\n' = Builder.fromString "\\n" - escape' char = escape char -stringValue (Pretty indentation) string = byStringType $ Text.lines string - where - byStringType [] = "\"\"" - byStringType [line] = Builder.toLazyText - $ quote <> Text.foldr (mappend . escape) quote line - byStringType lines' = "\"\"\"\n" - <> Lazy.Text.unlines (transformLine <$> lines') - <> indent indentation - <> "\"\"\"" - transformLine = (indent (indentation + 1) <>) - . Lazy.Text.fromStrict - . Text.replace "\"\"\"" "\\\"\"\"" - quote = Builder.singleton '\"' + $ quote <> Text.foldr (mappend . escape) quote string +stringValue (Pretty indentation) string = + if hasEscaped string + then stringValue Minified string + else Builder.toLazyText $ encoded lines' + where + isWhiteSpace char = char == ' ' || char == '\t' + isNewline char = char == '\n' || char == '\r' + hasEscaped = Text.any (not . isAllowed) + isAllowed char = + char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F') + tripleQuote = Builder.fromText "\"\"\"" + start = tripleQuote <> Builder.singleton '\n' + end = Builder.fromLazyText (indent indentation) <> tripleQuote + + 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 + escape :: Char -> Builder escape char' | char' == '\\' = Builder.fromString "\\\\" | char' == '\"' = Builder.fromString "\\\"" | char' == '\b' = Builder.fromString "\\b" | char' == '\f' = Builder.fromString "\\f" + | char' == '\n' = Builder.fromString "\\n" | char' == '\r' = Builder.fromString "\\r" + | char' == '\t' = Builder.fromString "\\t" | char' < '\x0010' = unicode "\\u000" char' | char' < '\x0020' = unicode "\\u00" char' | otherwise = Builder.singleton char' diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -15,6 +15,7 @@ , dollar , comment , equals + , extend , integer , float , lexeme @@ -28,20 +29,16 @@ , unicodeBOM ) where -import Control.Applicative ( Alternative(..) - , liftA2 - ) -import Data.Char ( chr - , digitToInt - , isAsciiLower - , isAsciiUpper - , ord - ) +import Control.Applicative (Alternative(..), liftA2) +import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord) import Data.Foldable (foldl') import Data.List (dropWhileEnd) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy (Proxy(..)) import Data.Void (Void) import Text.Megaparsec ( Parsec + , () , between , chunk , chunkToTokens @@ -56,11 +53,9 @@ , takeWhile1P , try ) -import Text.Megaparsec.Char ( char - , digitChar - , space1 - ) +import Text.Megaparsec.Char (char, digitChar, space1) import qualified Text.Megaparsec.Char.Lexer as Lexer +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -97,8 +92,8 @@ dollar = symbol "$" -- | Parser for "@". -at :: Parser Char -at = char '@' +at :: Parser Text +at = symbol "@" -- | Parser for "&". amp :: Parser T.Text @@ -134,7 +129,7 @@ -- | Parser for strings. string :: Parser T.Text -string = between "\"" "\"" stringValue <* spaceConsumer +string = between "\"" "\"" stringValue <* spaceConsumer where stringValue = T.pack <$> many stringCharacter stringCharacter = satisfy isStringCharacter1 @@ -143,7 +138,7 @@ -- | Parser for block strings. blockString :: Parser T.Text -blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer +blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer where stringValue = do byLine <- sepBy (many blockStringCharacter) lineTerminator @@ -226,3 +221,16 @@ -- | Parser for the "Byte Order Mark". unicodeBOM :: Parser () unicodeBOM = optional (char '\xfeff') >> pure () + +-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions. +extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a +extend token extensionLabel parsers + = foldr combine headParser (NonEmpty.tail parsers) + extensionLabel + where + headParser = tryExtension $ NonEmpty.head parsers + combine current accumulated = accumulated <|> tryExtension current + tryExtension extensionParser = try + $ symbol "extend" + *> symbol token + *> extensionParser diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -6,63 +6,358 @@ ( document ) where -import Control.Applicative ( Alternative(..) - , optional - ) +import Control.Applicative (Alternative(..), optional) +import Control.Applicative.Combinators (sepBy1) +import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) -import Language.GraphQL.AST +import Data.Text (Text) +import qualified Language.GraphQL.AST.DirectiveLocation as Directive +import Language.GraphQL.AST.DirectiveLocation + ( DirectiveLocation + , ExecutableDirectiveLocation + , TypeSystemDirectiveLocation + ) +import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer -import Text.Megaparsec ( lookAhead - , option - , try - , () - ) +import Text.Megaparsec (lookAhead, option, try, ()) -- | Parser for the GraphQL documents. document :: Parser Document -document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition) +document = unicodeBOM + >> spaceConsumer + >> lexeme (NonEmpty.some definition) definition :: Parser Definition -definition = DefinitionOperation <$> operationDefinition - <|> DefinitionFragment <$> fragmentDefinition - "definition error!" +definition = ExecutableDefinition <$> executableDefinition + <|> TypeSystemDefinition <$> typeSystemDefinition + <|> TypeSystemExtension <$> typeSystemExtension + "Definition" +executableDefinition :: Parser ExecutableDefinition +executableDefinition = DefinitionOperation <$> operationDefinition + <|> DefinitionFragment <$> fragmentDefinition + "ExecutableDefinition" + +typeSystemDefinition :: Parser TypeSystemDefinition +typeSystemDefinition = schemaDefinition + <|> TypeDefinition <$> typeDefinition + <|> directiveDefinition + "TypeSystemDefinition" + +typeSystemExtension :: Parser TypeSystemExtension +typeSystemExtension = SchemaExtension <$> schemaExtension + <|> TypeExtension <$> typeExtension + "TypeSystemExtension" + +directiveDefinition :: Parser TypeSystemDefinition +directiveDefinition = DirectiveDefinition + <$> description + <* symbol "directive" + <* at + <*> name + <*> argumentsDefinition + <* symbol "on" + <*> directiveLocations + "DirectiveDefinition" + +directiveLocations :: Parser (NonEmpty DirectiveLocation) +directiveLocations = optional pipe + *> directiveLocation `NonEmpty.sepBy1` pipe + +directiveLocation :: Parser DirectiveLocation +directiveLocation + = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation + <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation + +executableDirectiveLocation :: Parser ExecutableDirectiveLocation +executableDirectiveLocation = Directive.Query <$ symbol "QUERY" + <|> Directive.Mutation <$ symbol "MUTATION" + <|> Directive.Subscription <$ symbol "SUBSCRIPTION" + <|> Directive.Field <$ symbol "FIELD" + <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION" + <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD" + <|> Directive.InlineFragment <$ "INLINE_FRAGMENT" + +typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation +typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" + <|> Directive.Scalar <$ symbol "SCALAR" + <|> Directive.Object <$ symbol "OBJECT" + <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION" + <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION" + <|> Directive.Interface <$ symbol "INTERFACE" + <|> Directive.Union <$ symbol "UNION" + <|> Directive.Enum <$ symbol "ENUM" + <|> 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 + "TypeDefinition" + +typeExtension :: Parser TypeExtension +typeExtension = scalarTypeExtension + <|> objectTypeExtension + <|> interfaceTypeExtension + <|> unionTypeExtension + <|> enumTypeExtension + <|> inputObjectTypeExtension + "TypeExtension" + +scalarTypeDefinition :: Parser TypeDefinition +scalarTypeDefinition = ScalarTypeDefinition + <$> description + <* symbol "scalar" + <*> name + <*> directives + "ScalarTypeDefinition" + +scalarTypeExtension :: Parser TypeExtension +scalarTypeExtension = extend "scalar" "ScalarTypeExtension" + $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] + +objectTypeDefinition :: Parser TypeDefinition +objectTypeDefinition = ObjectTypeDefinition + <$> description + <* symbol "type" + <*> name + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> directives + <*> braces (many fieldDefinition) + "ObjectTypeDefinition" + +objectTypeExtension :: Parser TypeExtension +objectTypeExtension = extend "type" "ObjectTypeExtension" + $ fieldsDefinitionExtension :| + [ directivesExtension + , implementsInterfacesExtension + ] + where + fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension + <$> name + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> directives + <*> braces (NonEmpty.some fieldDefinition) + directivesExtension = ObjectTypeDirectivesExtension + <$> name + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> NonEmpty.some directive + implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension + <$> name + <*> implementsInterfaces NonEmpty.sepBy1 + +description :: Parser Description +description = Description + <$> optional (string <|> blockString) + "Description" + +unionTypeDefinition :: Parser TypeDefinition +unionTypeDefinition = UnionTypeDefinition + <$> description + <* symbol "union" + <*> name + <*> directives + <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) + "UnionTypeDefinition" + +unionTypeExtension :: Parser TypeExtension +unionTypeExtension = extend "union" "UnionTypeExtension" + $ unionMemberTypesExtension :| [directivesExtension] + where + unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension + <$> name + <*> directives + <*> unionMemberTypes NonEmpty.sepBy1 + directivesExtension = UnionTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +unionMemberTypes :: + Foldable t => + (Parser Text -> Parser Text -> Parser (t NamedType)) -> + Parser (UnionMemberTypes t) +unionMemberTypes sepBy' = UnionMemberTypes + <$ equals + <* optional pipe + <*> name `sepBy'` pipe + "UnionMemberTypes" + +interfaceTypeDefinition :: Parser TypeDefinition +interfaceTypeDefinition = InterfaceTypeDefinition + <$> description + <* symbol "interface" + <*> name + <*> directives + <*> braces (many fieldDefinition) + "InterfaceTypeDefinition" + +interfaceTypeExtension :: Parser TypeExtension +interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" + $ fieldsDefinitionExtension :| [directivesExtension] + where + fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension + <$> name + <*> directives + <*> braces (NonEmpty.some fieldDefinition) + directivesExtension = InterfaceTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +enumTypeDefinition :: Parser TypeDefinition +enumTypeDefinition = EnumTypeDefinition + <$> description + <* symbol "enum" + <*> name + <*> directives + <*> listOptIn braces enumValueDefinition + "EnumTypeDefinition" + +enumTypeExtension :: Parser TypeExtension +enumTypeExtension = extend "enum" "EnumTypeExtension" + $ enumValuesDefinitionExtension :| [directivesExtension] + where + enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension + <$> name + <*> directives + <*> braces (NonEmpty.some enumValueDefinition) + directivesExtension = EnumTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +inputObjectTypeDefinition :: Parser TypeDefinition +inputObjectTypeDefinition = InputObjectTypeDefinition + <$> description + <* symbol "input" + <*> name + <*> directives + <*> listOptIn braces inputValueDefinition + "InputObjectTypeDefinition" + +inputObjectTypeExtension :: Parser TypeExtension +inputObjectTypeExtension = extend "input" "InputObjectTypeExtension" + $ inputFieldsDefinitionExtension :| [directivesExtension] + where + inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension + <$> name + <*> directives + <*> braces (NonEmpty.some inputValueDefinition) + directivesExtension = InputObjectTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +enumValueDefinition :: Parser EnumValueDefinition +enumValueDefinition = EnumValueDefinition + <$> description + <*> enumValue + <*> directives + "EnumValueDefinition" + +implementsInterfaces :: + Foldable t => + (Parser Text -> Parser Text -> Parser (t NamedType)) -> + Parser (ImplementsInterfaces t) +implementsInterfaces sepBy' = ImplementsInterfaces + <$ symbol "implements" + <* optional amp + <*> name `sepBy'` amp + "ImplementsInterfaces" + +inputValueDefinition :: Parser InputValueDefinition +inputValueDefinition = InputValueDefinition + <$> description + <*> name + <* colon + <*> type' + <*> defaultValue + <*> directives + "InputValueDefinition" + +argumentsDefinition :: Parser ArgumentsDefinition +argumentsDefinition = ArgumentsDefinition + <$> listOptIn parens inputValueDefinition + "ArgumentsDefinition" + +fieldDefinition :: Parser FieldDefinition +fieldDefinition = FieldDefinition + <$> description + <*> name + <*> argumentsDefinition + <* colon + <*> type' + <*> directives + "FieldDefinition" + +schemaDefinition :: Parser TypeSystemDefinition +schemaDefinition = SchemaDefinition + <$ symbol "schema" + <*> directives + <*> operationTypeDefinitions + "SchemaDefinition" + +operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition) +operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition + +schemaExtension :: Parser SchemaExtension +schemaExtension = extend "schema" "SchemaExtension" + $ schemaOperationExtension :| [directivesExtension] + where + directivesExtension = SchemaDirectivesExtension + <$> NonEmpty.some directive + schemaOperationExtension = SchemaOperationExtension + <$> directives + <*> operationTypeDefinitions + +operationTypeDefinition :: Parser OperationTypeDefinition +operationTypeDefinition = OperationTypeDefinition + <$> operationType <* colon + <*> name + "OperationTypeDefinition" + operationDefinition :: Parser OperationDefinition -operationDefinition = OperationSelectionSet <$> selectionSet - <|> OperationDefinition <$> operationType - <*> optional name - <*> opt variableDefinitions - <*> opt directives - <*> selectionSet - "operationDefinition error" +operationDefinition = SelectionSet <$> selectionSet + <|> operationDefinition' + "operationDefinition error" + where + operationDefinition' + = OperationDefinition <$> operationType + <*> optional name + <*> variableDefinitions + <*> directives + <*> selectionSet operationType :: Parser OperationType operationType = Query <$ symbol "query" <|> Mutation <$ symbol "mutation" - "operationType error" + -- Keep default error message -- * SelectionSet selectionSet :: Parser SelectionSet -selectionSet = braces $ manyNE selection +selectionSet = braces $ NonEmpty.some selection selectionSetOpt :: Parser SelectionSetOpt -selectionSetOpt = braces $ some selection +selectionSetOpt = listOptIn braces selection selection :: Parser Selection -selection = SelectionField <$> field - <|> try (SelectionFragmentSpread <$> fragmentSpread) - <|> SelectionInlineFragment <$> inlineFragment - "selection error!" +selection = field + <|> try fragmentSpread + <|> inlineFragment + "selection error!" -- * Field -field :: Parser Field -field = Field <$> optional alias - <*> name - <*> opt arguments - <*> opt directives - <*> opt selectionSetOpt +field :: Parser Selection +field = Field + <$> optional alias + <*> name + <*> arguments + <*> directives + <*> selectionSetOpt alias :: Parser Alias alias = try $ name <* colon @@ -70,30 +365,32 @@ -- * Arguments arguments :: Parser [Argument] -arguments = parens $ some argument +arguments = listOptIn parens argument argument :: Parser Argument argument = Argument <$> name <* colon <*> value -- * Fragments -fragmentSpread :: Parser FragmentSpread -fragmentSpread = FragmentSpread <$ spread - <*> fragmentName - <*> opt directives +fragmentSpread :: Parser Selection +fragmentSpread = FragmentSpread + <$ spread + <*> fragmentName + <*> directives -inlineFragment :: Parser InlineFragment -inlineFragment = InlineFragment <$ spread - <*> optional typeCondition - <*> opt directives - <*> selectionSet +inlineFragment :: Parser Selection +inlineFragment = InlineFragment + <$ spread + <*> optional typeCondition + <*> directives + <*> selectionSet fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition <$ symbol "fragment" <*> name <*> typeCondition - <*> opt directives + <*> directives <*> selectionSet fragmentName :: Parser Name @@ -121,68 +418,68 @@ booleanValue = True <$ symbol "true" <|> False <$ symbol "false" - enumValue :: Parser Name - enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name - listValue :: Parser [Value] listValue = brackets $ some value objectValue :: Parser [ObjectField] objectValue = braces $ some objectField +enumValue :: Parser Name +enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name + objectField :: Parser ObjectField -objectField = ObjectField <$> name <* symbol ":" <*> value +objectField = ObjectField <$> name <* colon <*> value -- * Variables variableDefinitions :: Parser [VariableDefinition] -variableDefinitions = parens $ some variableDefinition +variableDefinitions = listOptIn parens variableDefinition variableDefinition :: Parser VariableDefinition -variableDefinition = VariableDefinition <$> variable - <* colon - <*> type_ - <*> optional defaultValue +variableDefinition = VariableDefinition + <$> variable + <* colon + <*> type' + <*> defaultValue + "VariableDefinition" + variable :: Parser Name variable = dollar *> name -defaultValue :: Parser Value -defaultValue = equals *> value +defaultValue :: Parser (Maybe Value) +defaultValue = optional (equals *> value) "DefaultValue" -- * Input Types -type_ :: Parser Type -type_ = try (TypeNonNull <$> nonNullType) - <|> TypeList <$> brackets type_ +type' :: Parser Type +type' = try (TypeNonNull <$> nonNullType) + <|> TypeList <$> brackets type' <|> TypeNamed <$> name - "type_ error!" + "Type" nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type_ <* bang + <|> NonNullTypeList <$> brackets type' <* bang "nonNullType error!" -- * Directives directives :: Parser [Directive] -directives = some directive +directives = many directive directive :: Parser Directive directive = Directive - <$ at - <*> name - <*> opt arguments + <$ at + <*> name + <*> arguments -- * Internal -opt :: Monoid a => Parser a -> Parser a -opt = option mempty +listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] +listOptIn surround = option [] . surround . some -- Hack to reverse parser success but :: Parser a -> Parser () but pn = False <$ lookAhead pn <|> pure True >>= \case False -> empty True -> pure () - -manyNE :: Alternative f => f a -> f (NonEmpty a) -manyNE p = (:|) <$> p <*> many p diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -20,18 +20,20 @@ , modify , runStateT ) -import Text.Megaparsec ( ParseErrorBundle(..) - , SourcePos(..) - , errorOffset - , parseErrorTextPretty - , reachOffset - , unPos - ) +import Text.Megaparsec + ( ParseErrorBundle(..) + , PosState(..) + , SourcePos(..) + , errorOffset + , parseErrorTextPretty + , reachOffset + , unPos + ) -- | Wraps a parse error into a list of errors. parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value parseError ParseErrorBundle{..} = - pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)] + pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)] where errorObject s SourcePos{..} = Aeson.object [ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s) @@ -39,7 +41,8 @@ , ("column", Aeson.toJSON $ unPos sourceColumn) ] go (result, state) x = - let (sourcePosition, _, newState) = reachOffset (errorOffset x) state + let (_, newState) = reachOffset (errorOffset x) state + sourcePosition = pstateSourcePos newState in (errorObject x sourcePosition : result, newState) -- | A wrapper to pass error messages around. diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -6,14 +6,14 @@ , executeWithName ) where -import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson -import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE +import qualified Data.List.NonEmpty as NonEmpty +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as Text -import qualified Language.GraphQL.AST as AST +import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.Core as AST.Core import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error @@ -24,13 +24,14 @@ -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -execute :: MonadIO m - => NonEmpty (Schema.Resolver m) -- ^ Resolvers. +execute :: Monad m + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. - -> AST.Document -- @GraphQL@ document. + -> Document -- @GraphQL@ document. -> m Aeson.Value execute schema subs doc = - maybe transformError (document schema Nothing) $ Transform.document subs doc + maybe transformError (document schema Nothing) + $ Transform.document subs doc where transformError = return $ singleError "Schema transformation error." @@ -40,24 +41,25 @@ -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -executeWithName :: MonadIO m - => NonEmpty (Schema.Resolver m) -- ^ Resolvers +executeWithName :: Monad m + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers -> Text -- ^ Operation name. -> Schema.Subs -- ^ Variable substitution function. - -> AST.Document -- ^ @GraphQL@ Document. + -> Document -- ^ @GraphQL@ Document. -> m Aeson.Value executeWithName schema name subs doc = - maybe transformError (document schema $ Just name) $ Transform.document subs doc + maybe transformError (document schema $ Just name) + $ Transform.document subs doc where transformError = return $ singleError "Schema transformation error." -document :: MonadIO m - => NonEmpty (Schema.Resolver m) +document :: Monad m + => HashMap Text (NonEmpty (Schema.Resolver m)) -> Maybe Text -> AST.Core.Document -> m Aeson.Value document schema Nothing (op :| []) = operation schema op -document schema (Just name) operations = case NE.dropWhile matchingName operations of +document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of [] -> return $ singleError $ Text.unwords ["Operation", name, "couldn't be found in the document."] (op:_) -> operation schema op @@ -67,11 +69,18 @@ matchingName _ = False document _ _ _ = return $ singleError "Missing operation name." -operation :: MonadIO m - => NonEmpty (Schema.Resolver m) +operation :: Monad m + => HashMap Text (NonEmpty (Schema.Resolver m)) -> AST.Core.Operation -> m Aeson.Value -operation schema (AST.Core.Query _ flds) - = runCollectErrs (Schema.resolve (toList schema) flds) -operation schema (AST.Core.Mutation _ flds) - = runCollectErrs (Schema.resolve (toList schema) flds) +operation schema = schemaOperation + where + runResolver fields = runCollectErrs + . flip Schema.resolve fields + . Schema.resolversToMap + resolve fields queryType = maybe lookupError (runResolver fields) + $ HashMap.lookup queryType schema + lookupError = pure + $ singleError "Root operation type couldn't be found in the schema." + schemaOperation (AST.Core.Query _ fields) = resolve fields "Query" + schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation" diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -11,7 +11,7 @@ import Control.Arrow (first) import Control.Monad (foldM, unless) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -19,6 +19,7 @@ import Data.Sequence (Seq, (<|), (><)) import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST.Core as Core +import Language.GraphQL.AST.Document (Definition(..), Document) import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Type.Directive as Directive @@ -35,18 +36,19 @@ -- | Rewrites the original syntax tree into an intermediate representation used -- for query execution. -document :: Schema.Subs -> Full.Document -> Maybe Core.Document +document :: Schema.Subs -> Document -> Maybe Core.Document document subs document' = flip runReaderT subs $ evalStateT (collectFragments >> operations operationDefinitions) $ Replacement HashMap.empty fragmentTable where (fragmentTable, operationDefinitions) = foldr defragment mempty document' - defragment (Full.DefinitionOperation definition) acc = + defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc = (definition :) <$> acc - defragment (Full.DefinitionFragment definition) acc = + defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc = let (Full.FragmentDefinition name _ _ _) = definition in first (HashMap.insert name definition) acc + defragment _ acc = acc -- * Operation @@ -56,26 +58,47 @@ lift . lift $ NonEmpty.nonEmpty coreOperations operation :: Full.OperationDefinition -> TransformT Core.Operation -operation (Full.OperationSelectionSet sels) = - operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels --- TODO: Validate Variable definitions with substituter -operation (Full.OperationDefinition Full.Query name _vars _dirs sels) = - Core.Query name <$> appendSelection sels -operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = - Core.Mutation name <$> appendSelection sels +operation (Full.SelectionSet sels) + = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels +operation (Full.OperationDefinition Full.Query name _vars _dirs sels) + = Core.Query name <$> appendSelection sels +operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) + = Core.Mutation name <$> appendSelection sels -- * Selection selection :: Full.Selection -> TransformT (Either (Seq Core.Selection) Core.Selection) -selection (Full.SelectionField field') = - maybe (Left mempty) (Right . Core.SelectionField) <$> field field' -selection (Full.SelectionFragmentSpread fragment) = - maybe (Left mempty) (Right . Core.SelectionFragment) - <$> fragmentSpread fragment -selection (Full.SelectionInlineFragment fragment) = - inlineFragment fragment +selection (Full.Field alias name arguments' directives' selections) = + maybe (Left mempty) (Right . Core.SelectionField) <$> do + fieldArguments <- arguments arguments' + fieldSelections <- appendSelection selections + fieldDirectives <- Directive.selection <$> directives directives' + let field' = Core.Field alias name fieldArguments fieldSelections + pure $ field' <$ fieldDirectives +selection (Full.FragmentSpread name directives') = + maybe (Left mempty) (Right . Core.SelectionFragment) <$> do + spreadDirectives <- Directive.selection <$> directives directives' + fragments' <- gets fragments + fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') + pure $ fragment <$ spreadDirectives + where + lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions + found <- lift . lift $ HashMap.lookup name fragmentDefinitions' + fragmentDefinition found +selection (Full.InlineFragment type' directives' selections) = do + fragmentDirectives <- Directive.selection <$> directives directives' + case fragmentDirectives of + Nothing -> pure $ Left mempty + _ -> do + fragmentSelectionSet <- appendSelection selections + pure $ maybe Left selectionFragment type' fragmentSelectionSet + where + selectionFragment typeName = Right + . Core.SelectionFragment + . Core.Fragment typeName appendSelection :: Traversable t => @@ -104,33 +127,6 @@ _ <- fragmentDefinition nextValue collectFragments -inlineFragment :: - Full.InlineFragment -> - TransformT (Either (Seq Core.Selection) Core.Selection) -inlineFragment (Full.InlineFragment type' directives' selectionSet) = do - fragmentDirectives <- Directive.selection <$> directives directives' - case fragmentDirectives of - Nothing -> pure $ Left mempty - _ -> do - fragmentSelectionSet <- appendSelection selectionSet - pure $ maybe Left selectionFragment type' fragmentSelectionSet - where - selectionFragment typeName = Right - . Core.SelectionFragment - . Core.Fragment typeName - -fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment) -fragmentSpread (Full.FragmentSpread name directives') = do - spreadDirectives <- Directive.selection <$> directives directives' - fragments' <- gets fragments - fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') - pure $ fragment <$ spreadDirectives - where - lookupDefinition = do - fragmentDefinitions' <- gets fragmentDefinitions - found <- lift . lift $ HashMap.lookup name fragmentDefinitions' - fragmentDefinition found - fragmentDefinition :: Full.FragmentDefinition -> TransformT Core.Fragment @@ -147,28 +143,15 @@ let newFragments = HashMap.insert name newValue fragments' in Replacement newFragments fragmentDefinitions' -field :: Full.Field -> TransformT (Maybe Core.Field) -field (Full.Field alias name arguments' directives' selections) = do - fieldArguments <- traverse argument arguments' - fieldSelections <- appendSelection selections - fieldDirectives <- Directive.selection <$> directives directives' - let field' = Core.Field alias name fieldArguments fieldSelections - pure $ field' <$ fieldDirectives - arguments :: [Full.Argument] -> TransformT Core.Arguments arguments = fmap Core.Arguments . foldM go HashMap.empty where - go arguments' argument' = do - (Core.Argument name value') <- argument argument' - return $ HashMap.insert name value' arguments' - -argument :: Full.Argument -> TransformT Core.Argument -argument (Full.Argument n v) = Core.Argument n <$> value v + go arguments' (Full.Argument name value') = do + substitutedValue <- value value' + return $ HashMap.insert name substitutedValue arguments' value :: Full.Value -> TransformT Core.Value -value (Full.Variable n) = do - substitute' <- lift ask - lift . lift $ substitute' n +value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift value (Full.Int i) = pure $ Core.Int i value (Full.Float f) = pure $ Core.Float f value (Full.String x) = pure $ Core.String x diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -3,28 +3,23 @@ -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Schema - ( Resolver + ( Resolver(..) , Subs , object - , objectA - , scalar - , scalarA , resolve + , resolversToMap + , scalar , wrappedObject - , wrappedObjectA , wrappedScalar - , wrappedScalarA -- * AST Reexports , Field - , Argument(..) , Value(..) ) where -import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) -import Data.Foldable (find, fold) +import Data.Foldable (fold, toList) import Data.Maybe (fromMaybe) import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) @@ -38,81 +33,80 @@ import qualified Language.GraphQL.Type as Type -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --- information (if an error has occurred). @m@ is usually expected to be an --- instance of 'MonadIO'. +-- information (if an error has occurred). @m@ is an arbitrary monad, usually +-- 'IO'. data Resolver m = Resolver Text -- ^ Name (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver --- | Variable substitution function. -type Subs = Name -> Maybe Value +-- | Converts resolvers to a map. +resolversToMap + :: (Foldable f, Functor f) + => f (Resolver m) + -> HashMap Text (Field -> CollectErrsT m Aeson.Object) +resolversToMap = HashMap.fromList . toList . fmap toKV + where + toKV (Resolver name f) = (name, f) --- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m -object name = objectA name . const +-- | Contains variables for the query. The key of the map is a variable name, +-- and the value is the variable value. +type Subs = HashMap Name Value --- | Like 'object' but also taking 'Argument's. -objectA :: MonadIO m - => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m -objectA name f = Resolver name $ resolveFieldValue f resolveRight +-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. +object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m +object name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld + resolveRight fld@(Field _ _ _ flds) resolver + = withField (resolve (resolversToMap resolver) flds) fld --- | Like 'object' but also taking 'Argument's and can be null or a list of objects. -wrappedObjectA :: MonadIO m - => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m -wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight +-- | Like 'object' but can be null or a list of objects. +wrappedObject :: + Monad m => + Name -> + ActionT m (Type.Wrapping [Resolver m]) -> + Resolver m +wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ sels) resolver - = withField (traverse (`resolve` sels) resolver) fld - --- | Like 'object' but can be null or a list of objects. -wrappedObject :: MonadIO m - => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m -wrappedObject name = wrappedObjectA name . const + = withField (traverse (resolveMap sels) resolver) fld + resolveMap = flip (resolve . resolversToMap) -- | A scalar represents a primitive value, like a string or an integer. -scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m -scalar name = scalarA name . const - --- | Like 'scalar' but also taking 'Argument's. -scalarA :: (MonadIO m, Aeson.ToJSON a) - => Name -> ([Argument] -> ActionT m a) -> Resolver m -scalarA name f = Resolver name $ resolveFieldValue f resolveRight +scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m +scalar name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld result = withField (return result) fld --- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars. -wrappedScalarA :: (MonadIO m, Aeson.ToJSON a) - => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m -wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight +-- | Like 'scalar' but can be null or a list of scalars. +wrappedScalar :: + (Monad m, Aeson.ToJSON a) => + Name -> + ActionT m (Type.Wrapping a) -> + Resolver m +wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld (Type.Named result) = withField (return result) fld resolveRight fld Type.Null = return $ HashMap.singleton (aliasOrName fld) Aeson.Null resolveRight fld (Type.List result) = withField (return result) fld --- | Like 'scalar' but can be null or a list of scalars. -wrappedScalar :: (MonadIO m, Aeson.ToJSON a) - => Name -> ActionT m (Type.Wrapping a) -> Resolver m -wrappedScalar name = wrappedScalarA name . const - -resolveFieldValue :: MonadIO m - => ([Argument] -> ActionT m a) - -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) - -> Field - -> CollectErrsT m (HashMap Text Aeson.Value) +resolveFieldValue :: + Monad m => + ActionT m a -> + (Field -> a -> CollectErrsT m Aeson.Object) -> + Field -> + CollectErrsT m (HashMap Text Aeson.Value) resolveFieldValue f resolveRight fld@(Field _ _ args _) = do - result <- lift $ reader . runExceptT . runActionT $ f args + result <- lift $ reader . runExceptT . runActionT $ f either resolveLeft (resolveRight fld) result where - reader = flip runReaderT $ Context mempty + reader = flip runReaderT $ Context {arguments=args} resolveLeft err = do _ <- addErrMsg err return $ HashMap.singleton (aliasOrName fld) Aeson.Null --- | Helper function to facilitate 'Argument' handling. -withField :: (MonadIO m, Aeson.ToJSON a) +-- | Helper function to facilitate error handling and result emitting. +withField :: (Monad m, Aeson.ToJSON a) => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) withField v fld = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v @@ -120,23 +114,22 @@ -- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. -resolve :: MonadIO m - => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value +resolve :: Monad m + => HashMap Text (Field -> CollectErrsT m Aeson.Object) + -> Seq Selection + -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers where - resolveTypeName (Resolver "__typename" f) = do + resolveTypeName f = do value <- f $ Field Nothing "__typename" mempty mempty return $ HashMap.lookupDefault "" "__typename" value - resolveTypeName _ = return "" tryResolvers (SelectionField fld@(Field _ name _ _)) - = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers + = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do - that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers) + that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers if maybe True (Aeson.String typeCondition ==) that then fmap fold . traverse tryResolvers $ selections' else return mempty - compareResolvers name (Resolver name' _) = name == name' - tryResolver fld (Resolver _ resolver) = resolver fld errmsg fld@(Field _ name _ _) = do addErrMsg $ T.unwords ["field", name, "not resolved."] return $ HashMap.singleton (aliasOrName fld) Aeson.Null diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -1,7 +1,8 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans ( ActionT(..) - , Context(Context) + , Context(..) + , argument ) where import Control.Applicative (Alternative(..)) @@ -9,13 +10,17 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Reader (ReaderT) -import Data.HashMap.Strict (HashMap) +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.Core (Name, Value) +import Language.GraphQL.AST.Core +import Prelude hiding (lookup) -- | Resolution context holds resolver arguments. -newtype Context = Context (HashMap Name Value) +newtype Context = Context + { arguments :: Arguments + } -- | Monad transformer stack used by the resolvers to provide error handling -- and resolution context (resolver arguments). @@ -47,3 +52,13 @@ 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 'Value.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/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -6,37 +6,124 @@ import Language.GraphQL.AST import Language.GraphQL.AST.Encoder -import Test.Hspec (Spec, context, describe, it, shouldBe) +import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) +import Test.QuickCheck (choose, oneof, forAll) import Text.RawString.QQ (r) +import Data.Text.Lazy (cons, toStrict, unpack) spec :: Spec spec = do describe "value" $ do + context "null value" $ do + let testNull formatter = value formatter Null `shouldBe` "null" + it "minified" $ testNull minified + it "pretty" $ testNull pretty + context "minified" $ do it "escapes \\" $ value minified (String "\\") `shouldBe` "\"\\\\\"" - it "escapes quotes" $ + it "escapes double quotes" $ value minified (String "\"") `shouldBe` "\"\\\"\"" + it "escapes \\f" $ + value minified (String "\f") `shouldBe` "\"\\f\"" + it "escapes \\n" $ + value minified (String "\n") `shouldBe` "\"\\n\"" + it "escapes \\r" $ + value minified (String "\r") `shouldBe` "\"\\r\"" + it "escapes \\t" $ + value minified (String "\t") `shouldBe` "\"\\t\"" it "escapes backspace" $ value minified (String "a\bc") `shouldBe` "\"a\\bc\"" - it "escapes Unicode" $ - value minified (String "\0") `shouldBe` "\"\\u0000\"" + context "escapes Unicode for chars less than 0010" $ do + it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\"" + it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\"" + context "escapes Unicode for char less than 0020" $ do + it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\"" + it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\"" + context "encodes without escape" $ do + it "space" $ value minified (String "\x0020") `shouldBe` "\" \"" + it "~" $ value minified (String "\x007E") `shouldBe` "\"~\"" context "pretty" $ do it "uses strings for short string values" $ value pretty (String "Short text") `shouldBe` "\"Short text\"" - it "uses block strings for text with new lines" $ + it "uses block strings for text with new lines, with newline symbol" $ value pretty (String "Line 1\nLine 2") - `shouldBe` "\"\"\"\n Line 1\n Line 2\n\"\"\"" - it "escapes \\ in short strings" $ - value pretty (String "\\") `shouldBe` "\"\\\\\"" + `shouldBe` [r|""" + Line 1 + Line 2 +"""|] + it "uses block strings for text with new lines, with CR symbol" $ + value pretty (String "Line 1\rLine 2") + `shouldBe` [r|""" + Line 1 + Line 2 +"""|] + it "uses block strings for text with new lines, with CR symbol followed by newline" $ + value pretty (String "Line 1\r\nLine 2") + `shouldBe` [r|""" + Line 1 + Line 2 +"""|] + it "encodes as one line string if has escaped symbols" $ do + let + genNotAllowedSymbol = oneof + [ choose ('\x0000', '\x0008') + , choose ('\x000B', '\x000C') + , choose ('\x000E', '\x001F') + , pure '\x007F' + ] + forAll genNotAllowedSymbol $ \x -> do + let + rawValue = "Short \n" <> cons x "text" + encoded = value pretty (String $ toStrict rawValue) + shouldStartWith (unpack encoded) "\"" + shouldEndWith (unpack encoded) "\"" + shouldNotContain (unpack encoded) "\"\"\"" + + it "Hello world" $ value pretty (String "Hello,\n World!\n\nYours,\n GraphQL.") + `shouldBe` [r|""" + Hello, + World! + + Yours, + GraphQL. +"""|] + + it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|""" + + +"""|] + it "has newlines and one symbol at the begining" $ + value pretty (String "a\n\n") `shouldBe` [r|""" + a + + +"""|] + it "has newlines and one symbol at the end" $ + value pretty (String "\n\na") `shouldBe` [r|""" + + + a +"""|] + it "has newlines and one symbol in the middle" $ + value pretty (String "\na\n") `shouldBe` [r|""" + + a + +"""|] + it "skip trailing whitespaces" $ value pretty (String " Short\ntext ") + `shouldBe` [r|""" + Short + text +"""|] + describe "definition" $ it "indents block strings in arguments" $ let arguments = [Argument "message" (String "line1\nline2")] field = Field Nothing "field" arguments [] [] - set = OperationSelectionSet $ pure $ SelectionField field - operation = DefinitionOperation set + operation = DefinitionOperation $ SelectionSet $ pure field in definition pretty operation `shouldBe` [r|{ field(message: """ line1 diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -8,7 +8,7 @@ import Data.Void (Void) import Language.GraphQL.AST.Lexer import Test.Hspec (Spec, context, describe, it) -import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn) +import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (ParseErrorBundle, parse) import Text.RawString.QQ (r) @@ -77,7 +77,7 @@ parse spread "" "..." `shouldParse` "..." parse colon "" ":" `shouldParse` ":" parse equals "" "=" `shouldParse` "=" - parse at "" "@" `shouldParse` '@' + parse at "" "@" `shouldParse` "@" runBetween brackets `shouldSucceedOn` "[]" runBetween braces `shouldSucceedOn` "{}" parse pipe "" "|" `shouldParse` "|" @@ -87,6 +87,13 @@ parse blockString "" [r|""""""|] `shouldParse` "" it "lexes ampersand" $ parse amp "" "&" `shouldParse` "&" + it "lexes schema extensions" $ + parseExtend "schema" `shouldSucceedOn` "extend schema" + it "fails if the given token doesn't match" $ + parseExtend "schema" `shouldFailOn` "extend shema" + +parseExtend :: Text -> (Text -> Either (ParseErrorBundle Text Void) ()) +parseExtend extension = parse (extend extension "" $ pure $ pure ()) "" runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) () runBetween parser = parse (parser $ pure ()) "" diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -4,9 +4,11 @@ ( spec ) where +import Data.List.NonEmpty (NonEmpty(..)) +import Language.GraphQL.AST.Document import Language.GraphQL.AST.Parser import Test.Hspec (Spec, describe, it) -import Test.Hspec.Megaparsec (shouldSucceedOn) +import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn) import Text.Megaparsec (parse) import Text.RawString.QQ (r) @@ -28,17 +30,115 @@ it "accepts two required arguments" $ parse document "" `shouldSucceedOn` [r| mutation auth($username: String!, $password: String!){ - test + test }|] it "accepts two string arguments" $ parse document "" `shouldSucceedOn` [r| mutation auth{ - test(username: "username", password: "password") + test(username: "username", password: "password") }|] it "accepts two block string arguments" $ parse document "" `shouldSucceedOn` [r| mutation auth{ - test(username: """username""", password: """password""") + test(username: """username""", password: """password""") }|] + + it "parses minimal schema definition" $ + parse document "" `shouldSucceedOn` [r|schema { query: Query }|] + + it "parses minimal scalar definition" $ + parse document "" `shouldSucceedOn` [r|scalar Time|] + + it "parses ImplementsInterfaces" $ + parse document "" `shouldSucceedOn` [r| + type Person implements NamedEntity & ValuedEntity { + name: String + } + |] + + it "parses a type without ImplementsInterfaces" $ + parse document "" `shouldSucceedOn` [r| + type Person { + name: String + } + |] + + it "parses ArgumentsDefinition in an ObjectDefinition" $ + parse document "" `shouldSucceedOn` [r| + type Person { + name(first: String, last: String): String + } + |] + + it "parses minimal union type definition" $ + parse document "" `shouldSucceedOn` [r| + union SearchResult = Photo | Person + |] + + it "parses minimal interface type definition" $ + parse document "" `shouldSucceedOn` [r| + interface NamedEntity { + name: String + } + |] + + it "parses minimal enum type definition" $ + parse document "" `shouldSucceedOn` [r| + enum Direction { + NORTH + EAST + SOUTH + WEST + } + |] + + it "parses minimal enum type definition" $ + parse document "" `shouldSucceedOn` [r| + enum Direction { + NORTH + EAST + SOUTH + WEST + } + |] + + it "parses minimal input object type definition" $ + parse document "" `shouldSucceedOn` [r| + input Point2D { + x: Float + y: Float + } + |] + + it "parses minimal input enum definition with an optional pipe" $ + parse document "" `shouldSucceedOn` [r| + directive @example on + | FIELD + | FRAGMENT_SPREAD + |] + + it "parses schema extension with a new directive" $ + parse document "" `shouldSucceedOn`[r| + extend schema @newDirective + |] + + it "parses schema extension with an operation type definition" $ + parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|] + + it "parses schema extension with an operation type and directive" $ + let newDirective = Directive "newDirective" [] + testSchemaExtension = TypeSystemExtension + $ SchemaExtension + $ SchemaOperationExtension [newDirective] + $ OperationTypeDefinition Query "Query" :| [] + query = [r|extend schema @newDirective { query: Query }|] + in parse document "" query `shouldParse` (testSchemaExtension :| []) + + it "parses an object extension" $ + parse document "" `shouldSucceedOn` [r| + extend type Story { + isHiddenLocally: Boolean + } + |] diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -5,14 +5,18 @@ ) where import Data.Aeson (Value, object, (.=)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) import Language.GraphQL import qualified Language.GraphQL.Schema as Schema import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) -experimentalResolver :: Schema.Resolver IO -experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int) +experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO)) +experimentalResolver = HashMap.singleton "Query" + $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| [] emptyObject :: Value emptyObject = object @@ -29,7 +33,7 @@ } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject it "should not skip fields if @skip is false" $ do @@ -44,7 +48,7 @@ ] ] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` expected it "should skip fields if @include is false" $ do @@ -54,7 +58,7 @@ } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject it "should be able to @skip a fragment spread" $ do @@ -68,7 +72,7 @@ } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject it "should be able to @skip an inline fragment" $ do @@ -80,5 +84,5 @@ } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -51,7 +51,7 @@ spec = do describe "Inline fragment executor" $ do it "chooses the first selection if the type matches" $ do - actual <- graphql (garment "Hat" :| []) inlineQuery + actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery let expected = object [ "data" .= object [ "garment" .= object @@ -62,7 +62,7 @@ in actual `shouldBe` expected it "chooses the last selection if the type matches" $ do - actual <- graphql (garment "Shirt" :| []) inlineQuery + actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery let expected = object [ "data" .= object [ "garment" .= object @@ -83,7 +83,7 @@ }|] resolvers = Schema.object "garment" $ return [circumference, size] - actual <- graphql (resolvers :| []) query + actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query let expected = object [ "data" .= object [ "garment" .= object @@ -101,7 +101,7 @@ } }|] - actual <- graphql (size :| []) query + actual <- graphql (HashMap.singleton "Query" $ size :| []) query actual `shouldNotSatisfy` hasErrors describe "Fragment spread executor" $ do @@ -116,7 +116,7 @@ } |] - actual <- graphql (circumference :| []) query + actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query let expected = object [ "data" .= object [ "circumference" .= (60 :: Int) @@ -141,7 +141,7 @@ } |] - actual <- graphql (garment "Hat" :| []) query + actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query let expected = object [ "data" .= object [ "garment" .= object @@ -162,7 +162,7 @@ } |] - actual <- graphql (circumference :| []) query + actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query actual `shouldSatisfy` hasErrors it "considers type condition" $ do @@ -187,5 +187,5 @@ ] ] ] - actual <- graphql (garment "Hat" :| []) query + actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query actual `shouldBe` expected diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -8,7 +8,6 @@ , getEpisode , getFriends , getHero - , getHeroIO , getHuman , id_ , homePlanet @@ -17,11 +16,8 @@ , typeName ) where -import Data.Monoid (mempty) -import Control.Applicative ( Alternative(..) - , liftA2 - ) -import Control.Monad.IO.Class (MonadIO(..)) +import Data.Functor.Identity (Identity) +import Control.Applicative (Alternative(..), liftA2) import Control.Monad.Trans.Except (throwE) import Data.Maybe (catMaybes) import Data.Text (Text) @@ -71,7 +67,7 @@ appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: MonadIO m => Character -> ActionT m Text +secretBackstory :: Character -> ActionT Identity Text secretBackstory = const $ ActionT $ throwE "secretBackstory is secret." typeName :: Character -> Text @@ -165,9 +161,6 @@ getHero :: Int -> Character getHero 5 = luke getHero _ = artoo - -getHeroIO :: Int -> IO Character -getHeroIO = pure . getHero getHuman :: Alternative f => ID -> f Character getHuman = fmap Right . getHuman' diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -5,20 +5,15 @@ ) where import qualified Data.Aeson as Aeson -import Data.Aeson ( object - , (.=) - ) +import Data.Aeson ((.=)) +import Data.Functor.Identity (Identity(..)) +import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL import Language.GraphQL.Schema (Subs) import Text.RawString.QQ (r) -import Test.Hspec.Expectations ( Expectation - , shouldBe - ) -import Test.Hspec ( Spec - , describe - , it - ) +import Test.Hspec.Expectations (Expectation, shouldBe) +import Test.Hspec (Spec, describe, it) import Test.StarWars.Schema -- * Test @@ -34,7 +29,11 @@ } } |] - $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]] + $ Aeson.object + [ "data" .= Aeson.object + [ "hero" .= Aeson.object ["id" .= ("2001" :: Text)] + ] + ] it "R2-D2 ID and friends" $ testQuery [r| query HeroNameAndFriendsQuery { hero { @@ -46,14 +45,14 @@ } } |] - $ object [ "data" .= object [ - "hero" .= object + $ Aeson.object [ "data" .= Aeson.object [ + "hero" .= Aeson.object [ "id" .= ("2001" :: Text) , r2d2Name , "friends" .= - [ object [lukeName] - , object [hanName] - , object [leiaName] + [ Aeson.object [lukeName] + , Aeson.object [hanName] + , Aeson.object [leiaName] ] ] ]] @@ -73,37 +72,37 @@ } } |] - $ object [ "data" .= object [ - "hero" .= object [ + $ Aeson.object [ "data" .= Aeson.object [ + "hero" .= Aeson.object [ "name" .= ("R2-D2" :: Text) , "friends" .= [ - object [ + Aeson.object [ "name" .= ("Luke Skywalker" :: Text) , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text] , "friends" .= [ - object [hanName] - , object [leiaName] - , object [c3poName] - , object [r2d2Name] + Aeson.object [hanName] + , Aeson.object [leiaName] + , Aeson.object [c3poName] + , Aeson.object [r2d2Name] ] ] - , object [ + , Aeson.object [ hanName , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] - , "friends" .= [ - object [lukeName] - , object [leiaName] - , object [r2d2Name] + , "friends" .= + [ Aeson.object [lukeName] + , Aeson.object [leiaName] + , Aeson.object [r2d2Name] ] ] - , object [ + , Aeson.object [ leiaName , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] - , "friends" .= [ - object [lukeName] - , object [hanName] - , object [c3poName] - , object [r2d2Name] + , "friends" .= + [ Aeson.object [lukeName] + , Aeson.object [hanName] + , Aeson.object [c3poName] + , Aeson.object [r2d2Name] ] ] ] @@ -116,40 +115,40 @@ } } |] - $ object [ "data" .= object [ - "human" .= object [lukeName] - ]] + $ Aeson.object [ "data" .= Aeson.object + [ "human" .= Aeson.object [lukeName] + ]] it "Luke ID with variable" $ testQueryParams - (\v -> if v == "someId" then Just "1000" else Nothing) + (HashMap.singleton "someId" "1000") [r| query FetchSomeIDQuery($someId: String!) { human(id: $someId) { name } } |] - $ object [ "data" .= object [ - "human" .= object [lukeName] + $ Aeson.object [ "data" .= Aeson.object [ + "human" .= Aeson.object [lukeName] ]] it "Han ID with variable" $ testQueryParams - (\v -> if v == "someId" then Just "1002" else Nothing) + (HashMap.singleton "someId" "1002") [r| query FetchSomeIDQuery($someId: String!) { human(id: $someId) { name } } |] - $ object [ "data" .= object [ - "human" .= object [hanName] + $ Aeson.object [ "data" .= Aeson.object [ + "human" .= Aeson.object [hanName] ]] it "Invalid ID" $ testQueryParams - (\v -> if v == "id" then Just "Not a valid ID" else Nothing) + (HashMap.singleton "id" "Not a valid ID") [r| query humanQuery($id: String!) { human(id: $id) { name } } - |] $ object ["data" .= object ["human" .= Aeson.Null]] + |] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]] it "Luke aliased" $ testQuery [r| query FetchLukeAliased { luke: human(id: "1000") { @@ -157,8 +156,8 @@ } } |] - $ object [ "data" .= object [ - "luke" .= object [lukeName] + $ Aeson.object [ "data" .= Aeson.object [ + "luke" .= Aeson.object [lukeName] ]] it "R2-D2 ID and friends aliased" $ testQuery [r| query HeroNameAndFriendsQuery { @@ -171,14 +170,14 @@ } } |] - $ object [ "data" .= object [ - "hero" .= object [ + $ Aeson.object [ "data" .= Aeson.object [ + "hero" .= Aeson.object [ "id" .= ("2001" :: Text) , r2d2Name - , "friends" .= [ - object ["friendName" .= ("Luke Skywalker" :: Text)] - , object ["friendName" .= ("Han Solo" :: Text)] - , object ["friendName" .= ("Leia Organa" :: Text)] + , "friends" .= + [ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)] + , Aeson.object ["friendName" .= ("Han Solo" :: Text)] + , Aeson.object ["friendName" .= ("Leia Organa" :: Text)] ] ] ]] @@ -192,9 +191,9 @@ } } |] - $ object [ "data" .= object [ - "luke" .= object [lukeName] - , "leia" .= object [leiaName] + $ Aeson.object [ "data" .= Aeson.object + [ "luke" .= Aeson.object [lukeName] + , "leia" .= Aeson.object [leiaName] ]] describe "Fragments for complex queries" $ do @@ -210,9 +209,9 @@ } } |] - $ object [ "data" .= object [ - "luke" .= object [lukeName, tatooine] - , "leia" .= object [leiaName, alderaan] + $ Aeson.object [ "data" .= Aeson.object [ + "luke" .= Aeson.object [lukeName, tatooine] + , "leia" .= Aeson.object [leiaName, alderaan] ]] it "Fragment for duplicate content" $ testQuery [r| query UseFragment { @@ -228,9 +227,9 @@ homePlanet } |] - $ object [ "data" .= object [ - "luke" .= object [lukeName, tatooine] - , "leia" .= object [leiaName, alderaan] + $ Aeson.object [ "data" .= Aeson.object [ + "luke" .= Aeson.object [lukeName, tatooine] + , "leia" .= Aeson.object [leiaName, alderaan] ]] describe "__typename" $ do @@ -242,8 +241,11 @@ } } |] - $ object ["data" .= object [ - "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name] + $ Aeson.object ["data" .= Aeson.object [ + "hero" .= Aeson.object + [ "__typename" .= ("Droid" :: Text) + , r2d2Name + ] ]] it "Luke is a human" $ testQuery [r| query CheckTypeOfLuke { @@ -253,8 +255,11 @@ } } |] - $ object ["data" .= object [ - "hero" .= object ["__typename" .= ("Human" :: Text), lukeName] + $ Aeson.object ["data" .= Aeson.object [ + "hero" .= Aeson.object + [ "__typename" .= ("Human" :: Text) + , lukeName + ] ]] describe "Errors in resolvers" $ do @@ -267,15 +272,15 @@ } } |] - $ object - [ "data" .= object - [ "hero" .= object + $ Aeson.object + [ "data" .= Aeson.object + [ "hero" .= Aeson.object [ "name" .= ("R2-D2" :: Text) , "secretBackstory" .= Aeson.Null ] ] , "errors" .= - [ object + [ Aeson.object ["message" .= ("secretBackstory is secret." :: Text)] ] ] @@ -290,19 +295,19 @@ } } |] - $ object ["data" .= object - [ "hero" .= object + $ Aeson.object ["data" .= Aeson.object + [ "hero" .= Aeson.object [ "name" .= ("R2-D2" :: Text) , "friends" .= - [ object + [ Aeson.object [ "name" .= ("Luke Skywalker" :: Text) , "secretBackstory" .= Aeson.Null ] - , object + , Aeson.object [ "name" .= ("Han Solo" :: Text) , "secretBackstory" .= Aeson.Null ] - , object + , Aeson.object [ "name" .= ("Leia Organa" :: Text) , "secretBackstory" .= Aeson.Null ] @@ -310,9 +315,15 @@ ] ] , "errors" .= - [ object ["message" .= ("secretBackstory is secret." :: Text)] - , object ["message" .= ("secretBackstory is secret." :: Text)] - , object ["message" .= ("secretBackstory is secret." :: Text)] + [ Aeson.object + [ "message" .= ("secretBackstory is secret." :: Text) + ] + , Aeson.object + [ "message" .= ("secretBackstory is secret." :: Text) + ] + , Aeson.object + [ "message" .= ("secretBackstory is secret." :: Text) + ] ] ] it "error on secretBackstory with alias" $ testQuery @@ -323,15 +334,17 @@ } } |] - $ object - [ "data" .= object - [ "mainHero" .= object + $ Aeson.object + [ "data" .= Aeson.object + [ "mainHero" .= Aeson.object [ "name" .= ("R2-D2" :: Text) , "story" .= Aeson.Null ] ] , "errors" .= - [ object ["message" .= ("secretBackstory is secret." :: Text)] + [ Aeson.object + [ "message" .= ("secretBackstory is secret." :: Text) + ] ] ] @@ -345,7 +358,8 @@ alderaan = "homePlanet" .= ("Alderaan" :: Text) testQuery :: Text -> Aeson.Value -> Expectation -testQuery q expected = graphql schema q >>= flip shouldBe expected +testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation -testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected +testQueryParams f q expected = + runIdentity (graphqlSubs schema f q) `shouldBe` expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Test.StarWars.Schema ( character @@ -10,9 +9,12 @@ import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift) -import Control.Monad.IO.Class (MonadIO(..)) +import Data.Functor.Identity (Identity) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes) +import Data.Text (Text) import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type @@ -20,32 +22,37 @@ -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: MonadIO m => NonEmpty (Schema.Resolver m) -schema = hero :| [human, droid] +schema :: HashMap Text (NonEmpty (Schema.Resolver Identity)) +schema = HashMap.singleton "Query" $ hero :| [human, droid] -hero :: MonadIO m => Schema.Resolver m -hero = Schema.objectA "hero" $ \case - [] -> character artoo - [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4 - [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5 - [Schema.Argument "episode" (Schema.Enum "JEDI" )] -> character $ getHero 6 - _ -> ActionT $ throwE "Invalid arguments." +hero :: Schema.Resolver Identity +hero = Schema.object "hero" $ do + episode <- argument "episode" + character $ case episode of + Schema.Enum "NEWHOPE" -> getHero 4 + Schema.Enum "EMPIRE" -> getHero 5 + Schema.Enum "JEDI" -> getHero 6 + _ -> artoo -human :: MonadIO m => Schema.Resolver m -human = Schema.wrappedObjectA "human" $ \case - [Schema.Argument "id" (Schema.String i)] -> do - humanCharacter <- lift $ return $ getHuman i >>= Just - case humanCharacter of - Nothing -> return Type.Null - Just e -> Type.Named <$> character e - _ -> ActionT $ throwE "Invalid arguments." +human :: Schema.Resolver Identity +human = Schema.wrappedObject "human" $ do + id' <- argument "id" + case id' of + Schema.String i -> do + humanCharacter <- lift $ return $ getHuman i >>= Just + case humanCharacter of + Nothing -> return Type.Null + Just e -> Type.Named <$> character e + _ -> ActionT $ throwE "Invalid arguments." -droid :: MonadIO m => Schema.Resolver m -droid = Schema.objectA "droid" $ \case - [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i) - _ -> ActionT $ throwE "Invalid arguments." +droid :: Schema.Resolver Identity +droid = Schema.object "droid" $ do + id' <- argument "id" + case id' of + Schema.String i -> character =<< getDroid i + _ -> ActionT $ throwE "Invalid arguments." -character :: MonadIO m => Character -> ActionT m [Schema.Resolver m] +character :: Character -> ActionT Identity [Schema.Resolver Identity] character char = return [ Schema.scalar "id" $ return $ id_ char , Schema.scalar "name" $ return $ name char