Support subscriptions

This is experimental support.
The implementation is based on conduit and is boring. There is a new
resolver data constructor that should create a source event stream. The
executor receives the events, pipes them through the normal execution
and puts them into the response stream which is returned to the user.

- Tests are missing.
- The executor should check field value resolver on subscription types.
- The graphql function should probably return (Either
  ResponseEventStream Response), but I'm not sure about this. It will
  make the usage more complicated if no subscriptions are involved, but
  with the current API implementing subscriptions is more
  difficult than it should be.
This commit is contained in:
Eugen Wissner 2020-07-14 19:37:56 +02:00
parent 840e129c44
commit ae2210f659
18 changed files with 288 additions and 158 deletions

View File

@ -22,16 +22,21 @@ and this project adheres to
- `Error.Response` represents a result of running a GraphQL query. - `Error.Response` represents a result of running a GraphQL query.
- `Type.Schema` exports `Type` which lists all types possible in the schema. - `Type.Schema` exports `Type` which lists all types possible in the schema.
- Parsing subscriptions (the execution always fails yet). - Parsing subscriptions (the execution always fails yet).
- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
`Type.Out.SourceEventStream` define subscription resolvers.
## Changed ## Changed
- `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver` - `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
has gone it is a better name for GraphQL resolvers. have value resolvers, root subscription type resolvers need an additional
resolver that creates an event stream. `Resolver` represents these differences
now and pairs a field with the function(s).
- All code from `Trans` is moved to `Type.Out` and exported by `Type` and - All code from `Trans` is moved to `Type.Out` and exported by `Type` and
`Type.Out`. `Type.Out`.
- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`. - `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
`AST` provides now only functionality related to parsing and encoding, as it `AST` provides now only functionality related to parsing and encoding, as it
should be. should be.
- `Execute.execute` takes an additional argument, a possible operation name. - `Execute.execute` takes an additional argument, a possible operation name
and returns either a stream or the response.
- `Error` module was changed to work with dedicated types for errors and the - `Error` module was changed to work with dedicated types for errors and the
response instead of JSON. response instead of JSON.
- `graphqlSubs` takes an additional argument, the operation name. The type of - `graphqlSubs` takes an additional argument, the operation name. The type of
@ -40,7 +45,9 @@ and this project adheres to
underlying functions (in the `Execute` module). underlying functions (in the `Execute` module).
## Removed ## Removed
- `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a - `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
represents possible resolver configurations.
- `Type.Out.Resolver`: It . Resolvers are a
part of the fields and are called `Trans.ResolverT`. part of the fields and are called `Trans.ResolverT`.
- `Execute.executeWithName`. `Execute.execute` takes the operation name and - `Execute.executeWithName`. `Execute.execute` takes the operation name and
completely replaces `executeWithName`. completely replaces `executeWithName`.

View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: c06170c5fd3d1c3e42fb8c8fde8afd88bf3dd142f6cee1f83128e8d00d443f2d -- hash: 38e16611476c6163a049a4ddbaef34cf3fdef8f85d25f7bcaed839372c9fdf75
name: graphql name: graphql
version: 0.8.0.0 version: 0.8.0.0
@ -53,6 +53,7 @@ library
Language.GraphQL.Type.Schema Language.GraphQL.Type.Schema
other-modules: other-modules:
Language.GraphQL.Execute.Execution Language.GraphQL.Execute.Execution
Language.GraphQL.Execute.Subscribe
Language.GraphQL.Execute.Transform Language.GraphQL.Execute.Transform
Language.GraphQL.Type.Definition Language.GraphQL.Type.Definition
Language.GraphQL.Type.Internal Language.GraphQL.Type.Internal
@ -61,6 +62,7 @@ library
build-depends: build-depends:
aeson aeson
, base >=4.7 && <5 , base >=4.7 && <5
, conduit
, containers , containers
, megaparsec , megaparsec
, parser-combinators , parser-combinators
@ -68,7 +70,6 @@ library
, text , text
, transformers , transformers
, unordered-containers , unordered-containers
, vector
default-language: Haskell2010 default-language: Haskell2010
test-suite tasty test-suite tasty
@ -97,6 +98,7 @@ test-suite tasty
QuickCheck QuickCheck
, aeson , aeson
, base >=4.7 && <5 , base >=4.7 && <5
, conduit
, containers , containers
, graphql , graphql
, hspec , hspec
@ -109,5 +111,4 @@ test-suite tasty
, text , text
, transformers , transformers
, unordered-containers , unordered-containers
, vector
default-language: Haskell2010 default-language: Haskell2010

View File

@ -28,6 +28,7 @@ data-files:
dependencies: dependencies:
- aeson - aeson
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- conduit
- containers - containers
- megaparsec - megaparsec
- parser-combinators - parser-combinators
@ -35,12 +36,12 @@ dependencies:
- text - text
- transformers - transformers
- unordered-containers - unordered-containers
- vector
library: library:
source-dirs: src source-dirs: src
other-modules: other-modules:
- Language.GraphQL.Execute.Execution - Language.GraphQL.Execute.Execution
- Language.GraphQL.Execute.Subscribe
- Language.GraphQL.Execute.Transform - Language.GraphQL.Execute.Transform
- Language.GraphQL.Type.Definition - Language.GraphQL.Type.Definition
- Language.GraphQL.Type.Internal - Language.GraphQL.Type.Internal

View File

@ -9,6 +9,7 @@ module Language.GraphQL
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import Data.Either (fromRight)
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST import Language.GraphQL.AST
@ -34,10 +35,14 @@ graphqlSubs :: Monad m
-> Aeson.Object -- ^ Variable substitution function. -> Aeson.Object -- ^ Variable substitution function.
-> Text -- ^ Text representing a @GraphQL@ request document. -> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response. -> m Aeson.Value -- ^ Response.
graphqlSubs schema operationName variableValues document' = graphqlSubs schema operationName variableValues document'
either parseError executeRequest parsed >>= formatResponse = either parseError executeRequest (parse document "" document')
>>= formatResponse
where where
parsed = parse document "" document' executeRequest parsed
= fromRight streamReturned
<$> execute schema operationName variableValues parsed
streamReturned = singleError "This service does not support subscriptions."
formatResponse (Response data'' Seq.Empty) = formatResponse (Response data'' Seq.Empty) =
pure $ Aeson.object [("data", data'')] pure $ Aeson.object [("data", data'')]
formatResponse (Response data'' errors') = pure $ Aeson.object formatResponse (Response data'' errors') = pure $ Aeson.object
@ -54,4 +59,3 @@ graphqlSubs schema operationName variableValues document' =
[ ("line", Aeson.toJSON line) [ ("line", Aeson.toJSON line)
, ("column", Aeson.toJSON column) , ("column", Aeson.toJSON column)
] ]
executeRequest = execute schema operationName variableValues

View File

@ -9,19 +9,20 @@ module Language.GraphQL.Error
, Error(..) , Error(..)
, Resolution(..) , Resolution(..)
, Response(..) , Response(..)
, ResponseEventStream
, addErr , addErr
, addErrMsg , addErrMsg
, runCollectErrs , runCollectErrs
, singleError , singleError
) where ) where
import Conduit
import Control.Monad.Trans.State (StateT, modify, runStateT) import Control.Monad.Trans.State (StateT, modify, runStateT)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..), (|>)) import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Void (Void)
import Language.GraphQL.AST (Location(..), Name) import Language.GraphQL.AST (Location(..), Name)
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
@ -96,6 +97,11 @@ data Response a = Response
, errors :: Seq Error , errors :: Seq Error
} deriving (Eq, Show) } deriving (Eq, Show)
-- | Each event in the underlying Source Stream triggers execution of the
-- subscription selection set. The results of the execution generate a Response
-- Stream.
type ResponseEventStream m a = ConduitT () (Response a) m ()
-- | Runs the given query computation, but collects the errors into an error -- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data. -- list, which is then sent back with the data.
runCollectErrs :: (Monad m, Serialize a) runCollectErrs :: (Monad m, Serialize a)

View File

@ -7,13 +7,13 @@ module Language.GraphQL.Execute
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..)) import Data.Sequence (Seq(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document (Document, Name) import Language.GraphQL.AST.Document (Document, Name)
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution import Language.GraphQL.Execute.Execution
import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Execute.Subscribe as Subscribe
import Language.GraphQL.Error import Language.GraphQL.Error
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
@ -28,24 +28,28 @@ import Language.GraphQL.Type.Schema
execute :: (Monad m, VariableValue a, Serialize b) execute :: (Monad m, VariableValue a, Serialize b)
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name. -> Maybe Text -- ^ Operation name.
-> HashMap.HashMap Name a -- ^ Variable substitution function. -> HashMap Name a -- ^ Variable substitution function.
-> Document -- @GraphQL@ document. -> Document -- @GraphQL@ document.
-> m (Response b) -> m (Either (ResponseEventStream m b) (Response b))
execute schema operationName subs document = execute schema operationName subs document =
case Transform.document schema operationName subs document of case Transform.document schema operationName subs document of
Left queryError -> pure $ singleError $ Transform.queryError queryError Left queryError -> pure
$ Right
$ singleError
$ Transform.queryError queryError
Right transformed -> executeRequest transformed Right transformed -> executeRequest transformed
executeRequest :: (Monad m, Serialize a) executeRequest :: (Monad m, Serialize a)
=> Transform.Document m => Transform.Document m
-> m (Response a) -> m (Either (ResponseEventStream m a) (Response a))
executeRequest (Transform.Document types' rootObjectType operation) executeRequest (Transform.Document types' rootObjectType operation)
| (Transform.Query _ fields) <- operation = | (Transform.Query _ fields) <- operation =
executeOperation types' rootObjectType fields Right <$> executeOperation types' rootObjectType fields
| (Transform.Mutation _ fields) <- operation = | (Transform.Mutation _ fields) <- operation =
executeOperation types' rootObjectType fields Right <$> executeOperation types' rootObjectType fields
| otherwise = | (Transform.Subscription _ fields) <- operation
pure $ singleError "This service does not support subscriptions." = either (Right . singleError) Left
<$> Subscribe.subscribe types' rootObjectType fields
-- This is actually executeMutation, but we don't distinguish between queries -- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet. -- and mutations yet.

View File

@ -3,7 +3,9 @@
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Language.GraphQL.Execute.Execution module Language.GraphQL.Execute.Execution
( executeSelectionSet ( coerceArgumentValues
, collectFields
, executeSelectionSet
) where ) where
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
@ -32,10 +34,10 @@ import Prelude hiding (null)
resolveFieldValue :: Monad m resolveFieldValue :: Monad m
=> Type.Value => Type.Value
-> Type.Subs -> Type.Subs
-> Type.ResolverT m a -> Type.Resolve m
-> m (Either Text a) -> m (Either Text Type.Value)
resolveFieldValue result args = resolveFieldValue result args resolver =
flip runReaderT context . runExceptT . Type.runResolverT flip runReaderT context $ runExceptT resolver
where where
context = Type.Context context = Type.Context
{ Type.arguments = Type.Arguments args { Type.arguments = Type.Arguments args
@ -101,12 +103,12 @@ instanceOf objectType (AbstractUnionType unionType) =
go unionMemberType acc = acc || objectType == unionMemberType go unionMemberType acc = acc || objectType == unionMemberType
executeField :: (Monad m, Serialize a) executeField :: (Monad m, Serialize a)
=> Out.Field m => Out.Resolver m
-> Type.Value -> Type.Value
-> NonEmpty (Transform.Field m) -> NonEmpty (Transform.Field m)
-> CollectErrsT m a -> CollectErrsT m a
executeField fieldDefinition prev fields = do executeField (Out.ValueResolver fieldDefinition resolver) prev fields = do
let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition let Out.Field _ fieldType argumentDefinitions = fieldDefinition
let (Transform.Field _ _ arguments' _ :| []) = fields let (Transform.Field _ _ arguments' _ :| []) = fields
case coerceArgumentValues argumentDefinitions arguments' of case coerceArgumentValues argumentDefinitions arguments' of
Nothing -> addErrMsg "Argument coercing failed." Nothing -> addErrMsg "Argument coercing failed."
@ -115,6 +117,7 @@ executeField fieldDefinition prev fields = do
case answer of case answer of
Right result -> completeValue fieldType fields result Right result -> completeValue fieldType fields result
Left errorMessage -> addErrMsg errorMessage Left errorMessage -> addErrMsg errorMessage
executeField _ _ _ = addErrMsg "No field value resolver specified."
completeValue :: (Monad m, Serialize a) completeValue :: (Monad m, Serialize a)
=> Out.Type m => Out.Type m

View File

@ -0,0 +1,92 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Execute.Subscribe
( subscribe
) where
import Conduit
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq(..))
import Data.Text (Text)
import Language.GraphQL.AST (Name)
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
-- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet.
subscribe :: (Monad m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
-> m (Either Text (ResponseEventStream m a))
subscribe types' objectType fields = do
sourceStream <- createSourceEventStream types' objectType fields
traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
mapSourceToResponseEvent :: (Monad m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
$ sourceStream
.| mapMC (executeSubscriptionEvent types' subscriptionType fields)
createSourceEventStream :: Monad m
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
-> m (Either Text (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
| [fieldGroup] <- Map.elems groupedFieldSet
, Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
, Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
case coerceArgumentValues argumentDefinitions arguments' of
Nothing -> pure $ Left "Argument coercion failed."
Just argumentValues ->
resolveFieldEventStream Type.Null argumentValues resolver
| otherwise = pure $ Left "Subscription contains more than one field."
where
groupedFieldSet = collectFields subscriptionType fields
resolveFieldEventStream :: Monad m
=> Type.Value
-> Type.Subs
-> ExceptT Text (ReaderT Out.Context m) (Out.SourceEventStream m)
-> m (Either Text (Out.SourceEventStream m))
resolveFieldEventStream result args resolver =
flip runReaderT context $ runExceptT resolver
where
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
}
-- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet.
executeSubscriptionEvent :: (Monad m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
-> Definition.Value
-> m (Response a)
executeSubscriptionEvent types' objectType fields initialValue =
runCollectErrs types' $ executeSelectionSet initialValue objectType fields

View File

@ -1,3 +1,7 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-- | Reexports non-conflicting type system and schema definitions. -- | Reexports non-conflicting type system and schema definitions.
module Language.GraphQL.Type module Language.GraphQL.Type
( In.InputField(..) ( In.InputField(..)
@ -6,7 +10,10 @@ module Language.GraphQL.Type
, Out.Field(..) , Out.Field(..)
, Out.InterfaceType(..) , Out.InterfaceType(..)
, Out.ObjectType(..) , Out.ObjectType(..)
, Out.ResolverT(..) , Out.Resolve
, Out.Resolver(..)
, Out.SourceEventStream
, Out.Subscribe
, Out.UnionType(..) , Out.UnionType(..)
, Out.argument , Out.argument
, module Language.GraphQL.Type.Definition , module Language.GraphQL.Type.Definition

View File

@ -1,3 +1,7 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
module Language.GraphQL.Type.Internal module Language.GraphQL.Type.Internal
@ -36,11 +40,13 @@ collectReferencedTypes schema =
collect traverser typeName element foundTypes collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes | HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes | otherwise = traverser $ HashMap.insert typeName element foundTypes
visitFields (Out.Field _ outputType arguments _) foundTypes visitFields (Out.Field _ outputType arguments) foundTypes
= traverseOutputType outputType = traverseOutputType outputType
$ foldr visitArguments foundTypes arguments $ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType visitArguments (In.Argument _ inputType _) = traverseInputType inputType
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
getField (Out.ValueResolver field _) = field
getField (Out.EventStreamResolver field _ _) = field
traverseInputType (In.InputObjectBaseType objectType) = traverseInputType (In.InputObjectBaseType objectType) =
let (In.InputObjectType typeName _ inputFields) = objectType let (In.InputObjectType typeName _ inputFields) = objectType
element = InputObjectType objectType element = InputObjectType objectType
@ -73,7 +79,7 @@ collectReferencedTypes schema =
traverseObjectType objectType foundTypes = traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType let (Out.ObjectType typeName _ interfaces fields) = objectType
element = ObjectType objectType element = ObjectType objectType
traverser = polymorphicTraverser interfaces fields traverser = polymorphicTraverser interfaces (getField <$> fields)
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes = traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType let (Out.InterfaceType typeName _ interfaces fields) = interfaceType

View File

@ -1,3 +1,7 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
@ -12,7 +16,10 @@ module Language.GraphQL.Type.Out
, Field(..) , Field(..)
, InterfaceType(..) , InterfaceType(..)
, ObjectType(..) , ObjectType(..)
, ResolverT(..) , Resolve
, Subscribe
, Resolver(..)
, SourceEventStream
, Type(..) , Type(..)
, UnionType(..) , UnionType(..)
, argument , argument
@ -25,10 +32,7 @@ module Language.GraphQL.Type.Out
, pattern UnionBaseType , pattern UnionBaseType
) where ) where
import Control.Applicative (Alternative(..)) import Conduit
import Control.Monad (MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Reader (ReaderT, asks) import Control.Monad.Trans.Reader (ReaderT, asks)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
@ -44,7 +48,7 @@ import qualified Language.GraphQL.Type.In as In
-- Almost all of the GraphQL types you define will be object types. Object -- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields. -- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType data ObjectType m = ObjectType
Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m)) Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
instance forall a. Eq (ObjectType a) where instance forall a. Eq (ObjectType a) where
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
@ -74,7 +78,6 @@ data Field m = Field
(Maybe Text) -- ^ Description. (Maybe Text) -- ^ Description.
(Type m) -- ^ Field type. (Type m) -- ^ Field type.
(HashMap Name In.Argument) -- ^ Arguments. (HashMap Name In.Argument) -- ^ Arguments.
(ResolverT m Value) -- ^ Resolver.
-- | These types may be used as output types as the result of fields. -- | These types may be used as output types as the result of fields.
-- --
@ -169,56 +172,41 @@ isNonNullType (NonNullUnionType _) = True
isNonNullType (NonNullListType _) = True isNonNullType (NonNullListType _) = True
isNonNullType _ = False isNonNullType _ = False
-- | Resolution context holds resolver arguments. -- | Resolution context holds resolver arguments and the root value.
data Context = Context data Context = Context
{ arguments :: Arguments { arguments :: Arguments
, values :: Value , values :: Value
} }
-- | Monad transformer stack used by the resolvers to provide error handling -- | Monad transformer stack used by the resolvers for determining the resolved
-- and resolution context (resolver arguments). -- value of a field.
type Resolve m = ExceptT Text (ReaderT Context m) Value
-- | Monad transformer stack used by the resolvers for determining the resolved
-- event stream of a subscription field.
type Subscribe m = ExceptT Text (ReaderT Context m) (SourceEventStream m)
-- | A source stream represents the sequence of events, each of which will
-- trigger a GraphQL execution corresponding to that event.
type SourceEventStream m = ConduitT () Value m ()
-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver'
-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves
-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a
-- root subscription type.
-- --
-- Resolves a 'Field' into a 'Value' with error information (if an error has -- The resolvers aren't part of the 'Field' itself because not all fields
-- occurred). @m@ is an arbitrary monad, usually 'IO'. -- have resolvers (interface fields don't have an implementation).
-- data Resolver m
-- Resolving a field can result in a leaf value or an object, which is = ValueResolver (Field m) (Resolve m)
-- represented as a list of nested resolvers, used to resolve the fields of that | EventStreamResolver (Field m) (Resolve m) (Subscribe m)
-- object.
newtype ResolverT m a = ResolverT
{ runResolverT :: ExceptT Text (ReaderT Context m) a
}
instance Functor m => Functor (ResolverT m) where
fmap f = ResolverT . fmap f . runResolverT
instance Monad m => Applicative (ResolverT m) where
pure = ResolverT . pure
(ResolverT f) <*> (ResolverT x) = ResolverT $ f <*> x
instance Monad m => Monad (ResolverT m) where
return = pure
(ResolverT action) >>= f = ResolverT $ action >>= runResolverT . f
instance MonadTrans ResolverT where
lift = ResolverT . lift . lift
instance MonadIO m => MonadIO (ResolverT m) where
liftIO = lift . liftIO
instance Monad m => Alternative (ResolverT m) where
empty = ResolverT empty
(ResolverT x) <|> (ResolverT y) = ResolverT $ x <|> y
instance Monad m => MonadPlus (ResolverT m) where
mzero = empty
mplus = (<|>)
-- | Retrieves an argument by its name. If the argument with this name couldn't -- | Retrieves an argument by its name. If the argument with this name couldn't
-- be found, returns 'Null' (i.e. the argument is assumed to -- be found, returns 'Null' (i.e. the argument is assumed to
-- be optional then). -- be optional then).
argument :: Monad m => Name -> ResolverT m Value argument :: Monad m => Name -> Resolve m
argument argumentName = do argument argumentName = do
argumentValue <- ResolverT $ lift $ asks $ lookupArgument . arguments argumentValue <- lift $ asks $ lookupArgument . arguments
pure $ fromMaybe Null argumentValue pure $ fromMaybe Null argumentValue
where where
lookupArgument (Arguments argumentMap) = lookupArgument (Arguments argumentMap) =

View File

@ -1,4 +1,4 @@
resolver: lts-16.4 resolver: lts-16.5
packages: packages:
- . - .

View File

@ -5,6 +5,7 @@ module Language.GraphQL.ExecuteSpec
import Data.Aeson ((.=)) import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Either (fromRight)
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
@ -22,26 +23,27 @@ schema = Schema {query = queryType, mutation = Nothing}
queryType :: Out.ObjectType Identity queryType :: Out.ObjectType Identity
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "philosopher" philosopherField $ HashMap.singleton "philosopher"
$ ValueResolver philosopherField
$ pure $ Type.Object mempty
where where
philosopherField philosopherField =
= Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
$ pure $ Type.Object mempty
philosopherType :: Out.ObjectType Identity philosopherType :: Out.ObjectType Identity
philosopherType = Out.ObjectType "Philosopher" Nothing [] philosopherType = Out.ObjectType "Philosopher" Nothing []
$ HashMap.fromList resolvers $ HashMap.fromList resolvers
where where
resolvers = resolvers =
[ ("firstName", firstNameField) [ ("firstName", ValueResolver firstNameField firstNameResolver)
, ("lastName", lastNameField) , ("lastName", ValueResolver lastNameField lastNameResolver)
] ]
firstNameField firstNameField =
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
$ pure $ Type.String "Friedrich" firstNameResolver = pure $ Type.String "Friedrich"
lastNameField lastNameField
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
$ pure $ Type.String "Nietzsche" lastNameResolver = pure $ Type.String "Nietzsche"
spec :: Spec spec :: Spec
spec = spec =
@ -54,8 +56,9 @@ spec =
] ]
expected = Response data'' mempty expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
actual = runIdentity actual = fromRight (singleError "")
$ either parseError execute' $ runIdentity
$ either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName surname } }" $ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected in actual `shouldBe` expected
it "merges selections" $ it "merges selections" $
@ -67,7 +70,8 @@ spec =
] ]
expected = Response data'' mempty expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
actual = runIdentity actual = fromRight (singleError "")
$ either parseError execute' $ runIdentity
$ either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }" $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
in actual `shouldBe` expected in actual `shouldBe` expected

View File

@ -16,10 +16,10 @@ import Text.RawString.QQ (r)
experimentalResolver :: Schema IO experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing } experimentalResolver = Schema { query = queryType, mutation = Nothing }
where where
resolver = pure $ Int 5
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolver $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 5
emptyObject :: Aeson.Value emptyObject :: Aeson.Value
emptyObject = object emptyObject = object

View File

@ -64,12 +64,14 @@ hatType = Out.ObjectType "Hat" Nothing []
, ("circumference", circumferenceFieldType) , ("circumference", circumferenceFieldType)
] ]
circumferenceFieldType :: Out.Field IO circumferenceFieldType :: Out.Resolver IO
circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty circumferenceFieldType
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ snd circumference $ pure $ snd circumference
sizeFieldType :: Out.Field IO sizeFieldType :: Out.Resolver IO
sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty sizeFieldType
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ pure $ snd size $ pure $ snd size
toSchema :: Text -> (Text, Value) -> Schema IO toSchema :: Text -> (Text, Value) -> Schema IO
@ -78,17 +80,15 @@ toSchema t (_, resolve) = Schema
where where
unionMember = if t == "Hat" then hatType else shirtType unionMember = if t == "Hat" then hatType else shirtType
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
$ pure $ String "Shirt"
garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
$ pure resolve
queryType = queryType =
case t of case t of
"circumference" -> hatType "circumference" -> hatType
"size" -> shirtType "size" -> shirtType
_ -> Out.ObjectType "Query" Nothing [] _ -> Out.ObjectType "Query" Nothing []
$ HashMap.fromList $ HashMap.fromList
[ ("garment", garmentField) [ ("garment", ValueResolver garmentField (pure resolve))
, ("__typename", typeNameField) , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
] ]
spec :: Spec spec :: Spec

View File

@ -15,23 +15,23 @@ import qualified Language.GraphQL.Type.Out as Out
hatType :: Out.ObjectType IO hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing [] hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton "circumference" $ HashMap.singleton "circumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ pure $ Int 60
$ Int 60
schema :: Schema IO schema :: Schema IO
schema = Schema schema = Schema
(Out.ObjectType "Query" Nothing [] hatField) (Out.ObjectType "Query" Nothing [] hatFieldResolver)
(Just $ Out.ObjectType "Mutation" Nothing [] incrementField) (Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver)
where where
garment = pure $ Object $ HashMap.fromList garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60) [ ("circumference", Int 60)
] ]
incrementField = HashMap.singleton "incrementCircumference" incrementFieldResolver = HashMap.singleton "incrementCircumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 61 $ pure $ Int 61
hatField = HashMap.singleton "garment" hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
$ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment hatFieldResolver =
HashMap.singleton "garment" $ ValueResolver hatField garment
spec :: Spec spec :: Spec
spec = spec =

View File

@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x
secretBackstory :: ResolverT Identity Text secretBackstory :: Resolve Identity
secretBackstory = ResolverT $ throwE "secretBackstory is secret." secretBackstory = throwE "secretBackstory is secret."
typeName :: Character -> Text typeName :: Character -> Text
typeName = either (const "Droid") (const "Human") typeName = either (const "Droid") (const "Human")
@ -161,10 +161,10 @@ getHero :: Int -> Character
getHero 5 = luke getHero 5 = luke
getHero _ = artoo getHero _ = artoo
getHuman :: Alternative f => ID -> f Character getHuman :: ID -> Maybe Character
getHuman = fmap Right . getHuman' getHuman = fmap Right . getHuman'
getHuman' :: Alternative f => ID -> f Human getHuman' :: ID -> Maybe Human
getHuman' "1000" = pure luke' getHuman' "1000" = pure luke'
getHuman' "1001" = pure vader getHuman' "1001" = pure vader
getHuman' "1002" = pure han getHuman' "1002" = pure han
@ -172,10 +172,10 @@ getHuman' "1003" = pure leia
getHuman' "1004" = pure tarkin getHuman' "1004" = pure tarkin
getHuman' _ = empty getHuman' _ = empty
getDroid :: Alternative f => ID -> f Character getDroid :: ID -> Maybe Character
getDroid = fmap Left . getDroid' getDroid = fmap Left . getDroid'
getDroid' :: Alternative f => ID -> f Droid getDroid' :: ID -> Maybe Droid
getDroid' "2000" = pure threepio getDroid' "2000" = pure threepio
getDroid' "2001" = pure artoo' getDroid' "2001" = pure artoo'
getDroid' _ = empty getDroid' _ = empty

View File

@ -23,19 +23,20 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing } schema = Schema { query = queryType, mutation = Nothing }
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", heroField) [ ("hero", heroFieldResolver)
, ("human", humanField) , ("human", humanFieldResolver)
, ("droid", droidField) , ("droid", droidFieldResolver)
] ]
heroArguments = HashMap.singleton "episode" heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "episode"
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
heroField = heroFieldResolver = ValueResolver heroField hero
Out.Field Nothing (Out.NamedObjectType heroObject) heroArguments hero humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
humanArguments = HashMap.singleton "id" $ HashMap.singleton "id"
$ In.Argument Nothing (In.NonNullScalarType string) Nothing $ In.Argument Nothing (In.NonNullScalarType string) Nothing
humanField = humanFieldResolver = ValueResolver humanField human
Out.Field Nothing (Out.NamedObjectType heroObject) humanArguments human droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid droidFieldResolver = ValueResolver droidField droid
heroObject :: Out.ObjectType Identity heroObject :: Out.ObjectType Identity
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
@ -48,8 +49,9 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
, ("__typename", typenameFieldType) , ("__typename", typenameFieldType)
] ]
where where
homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty homePlanetFieldType
$ idField "homePlanet" = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "homePlanet"
droidObject :: Out.ObjectType Identity droidObject :: Out.ObjectType Identity
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
@ -62,39 +64,48 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
, ("__typename", typenameFieldType) , ("__typename", typenameFieldType)
] ]
where where
primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty primaryFunctionFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "primaryFunction" $ idField "primaryFunction"
typenameFieldType :: Out.Field Identity typenameFieldType :: Resolver Identity
typenameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty typenameFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "__typename" $ idField "__typename"
idFieldType :: Out.Field Identity idFieldType :: Resolver Identity
idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty idFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
$ idField "id" $ idField "id"
nameFieldType :: Out.Field Identity nameFieldType :: Resolver Identity
nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty nameFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "name" $ idField "name"
friendsFieldType :: Out.Field Identity friendsFieldType :: Resolver Identity
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty friendsFieldType
= ValueResolver (Out.Field Nothing fieldType mempty)
$ idField "friends" $ idField "friends"
where
fieldType = Out.ListType $ Out.NamedObjectType droidObject
appearsInField :: Out.Field Identity appearsInField :: Resolver Identity
appearsInField = Out.Field (Just description) fieldType mempty appearsInField
= ValueResolver (Out.Field (Just description) fieldType mempty)
$ idField "appearsIn" $ idField "appearsIn"
where where
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
description = "Which movies they appear in." description = "Which movies they appear in."
secretBackstoryFieldType :: Out.Field Identity secretBackstoryFieldType :: Resolver Identity
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty secretBackstoryFieldType = ValueResolver field secretBackstory
$ String <$> secretBackstory where
field = Out.Field Nothing (Out.NamedScalarType string) mempty
idField :: Text -> ResolverT Identity Value idField :: Text -> Resolve Identity
idField f = do idField f = do
v <- ResolverT $ lift $ asks values v <- lift $ asks values
let (Object v') = v let (Object v') = v
pure $ v' HashMap.! f pure $ v' HashMap.! f
@ -107,7 +118,7 @@ episodeEnum = EnumType "Episode" (Just description)
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.") empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
jedi = ("JEDI", EnumValue $ Just "Released in 1983.") jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
hero :: ResolverT Identity Value hero :: Resolve Identity
hero = do hero = do
episode <- argument "episode" episode <- argument "episode"
pure $ character $ case episode of pure $ character $ case episode of
@ -116,23 +127,19 @@ hero = do
Enum "JEDI" -> getHero 6 Enum "JEDI" -> getHero 6
_ -> artoo _ -> artoo
human :: ResolverT Identity Value human :: Resolve Identity
human = do human = do
id' <- argument "id" id' <- argument "id"
case id' of case id' of
String i -> do String i -> pure $ maybe Null character $ getHuman i >>= Just
humanCharacter <- lift $ return $ getHuman i >>= Just _ -> throwE "Invalid arguments."
case humanCharacter of
Nothing -> pure Null
Just e -> pure $ character e
_ -> ResolverT $ throwE "Invalid arguments."
droid :: ResolverT Identity Value droid :: Resolve Identity
droid = do droid = do
id' <- argument "id" id' <- argument "id"
case id' of case id' of
String i -> character <$> getDroid i String i -> pure $ maybe Null character $ getDroid i >>= Just
_ -> ResolverT $ throwE "Invalid arguments." _ -> throwE "Invalid arguments."
character :: Character -> Value character :: Character -> Value
character char = Object $ HashMap.fromList character char = Object $ HashMap.fromList