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:
parent
840e129c44
commit
ae2210f659
15
CHANGELOG.md
15
CHANGELOG.md
|
|
@ -22,16 +22,21 @@ and this project adheres to
|
|||
- `Error.Response` represents a result of running a GraphQL query.
|
||||
- `Type.Schema` exports `Type` which lists all types possible in the schema.
|
||||
- Parsing subscriptions (the execution always fails yet).
|
||||
- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
|
||||
`Type.Out.SourceEventStream` define subscription resolvers.
|
||||
|
||||
## Changed
|
||||
- `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver`
|
||||
has gone it is a better name for GraphQL resolvers.
|
||||
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
||||
have value resolvers, root subscription type resolvers need an additional
|
||||
resolver that creates an event stream. `Resolver` represents these differences
|
||||
now and pairs a field with the function(s).
|
||||
- All code from `Trans` is moved to `Type.Out` and exported by `Type` and
|
||||
`Type.Out`.
|
||||
- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
|
||||
`AST` provides now only functionality related to parsing and encoding, as it
|
||||
should be.
|
||||
- `Execute.execute` takes an additional argument, a possible operation name.
|
||||
- `Execute.execute` takes an additional argument, a possible operation name
|
||||
and returns either a stream or the response.
|
||||
- `Error` module was changed to work with dedicated types for errors and the
|
||||
response instead of JSON.
|
||||
- `graphqlSubs` takes an additional argument, the operation name. The type of
|
||||
|
|
@ -40,7 +45,9 @@ and this project adheres to
|
|||
underlying functions (in the `Execute` module).
|
||||
|
||||
## 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`.
|
||||
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
|
||||
completely replaces `executeWithName`.
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: c06170c5fd3d1c3e42fb8c8fde8afd88bf3dd142f6cee1f83128e8d00d443f2d
|
||||
-- hash: 38e16611476c6163a049a4ddbaef34cf3fdef8f85d25f7bcaed839372c9fdf75
|
||||
|
||||
name: graphql
|
||||
version: 0.8.0.0
|
||||
|
|
@ -53,6 +53,7 @@ library
|
|||
Language.GraphQL.Type.Schema
|
||||
other-modules:
|
||||
Language.GraphQL.Execute.Execution
|
||||
Language.GraphQL.Execute.Subscribe
|
||||
Language.GraphQL.Execute.Transform
|
||||
Language.GraphQL.Type.Definition
|
||||
Language.GraphQL.Type.Internal
|
||||
|
|
@ -61,6 +62,7 @@ library
|
|||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, conduit
|
||||
, containers
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
|
|
@ -68,7 +70,6 @@ library
|
|||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tasty
|
||||
|
|
@ -97,6 +98,7 @@ test-suite tasty
|
|||
QuickCheck
|
||||
, aeson
|
||||
, base >=4.7 && <5
|
||||
, conduit
|
||||
, containers
|
||||
, graphql
|
||||
, hspec
|
||||
|
|
@ -109,5 +111,4 @@ test-suite tasty
|
|||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ data-files:
|
|||
dependencies:
|
||||
- aeson
|
||||
- base >= 4.7 && < 5
|
||||
- conduit
|
||||
- containers
|
||||
- megaparsec
|
||||
- parser-combinators
|
||||
|
|
@ -35,12 +36,12 @@ dependencies:
|
|||
- text
|
||||
- transformers
|
||||
- unordered-containers
|
||||
- vector
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
other-modules:
|
||||
- Language.GraphQL.Execute.Execution
|
||||
- Language.GraphQL.Execute.Subscribe
|
||||
- Language.GraphQL.Execute.Transform
|
||||
- Language.GraphQL.Type.Definition
|
||||
- Language.GraphQL.Type.Internal
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ module Language.GraphQL
|
|||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Either (fromRight)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST
|
||||
|
|
@ -34,10 +35,14 @@ graphqlSubs :: Monad m
|
|||
-> Aeson.Object -- ^ Variable substitution function.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m Aeson.Value -- ^ Response.
|
||||
graphqlSubs schema operationName variableValues document' =
|
||||
either parseError executeRequest parsed >>= formatResponse
|
||||
graphqlSubs schema operationName variableValues document'
|
||||
= either parseError executeRequest (parse document "" document')
|
||||
>>= formatResponse
|
||||
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) =
|
||||
pure $ Aeson.object [("data", data'')]
|
||||
formatResponse (Response data'' errors') = pure $ Aeson.object
|
||||
|
|
@ -54,4 +59,3 @@ graphqlSubs schema operationName variableValues document' =
|
|||
[ ("line", Aeson.toJSON line)
|
||||
, ("column", Aeson.toJSON column)
|
||||
]
|
||||
executeRequest = execute schema operationName variableValues
|
||||
|
|
|
|||
|
|
@ -9,19 +9,20 @@ module Language.GraphQL.Error
|
|||
, Error(..)
|
||||
, Resolution(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, runCollectErrs
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Void (Void)
|
||||
import Language.GraphQL.AST (Location(..), Name)
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Type.Schema
|
||||
|
|
@ -96,6 +97,11 @@ data Response a = Response
|
|||
, errors :: Seq Error
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | Each event in the underlying Source Stream triggers execution of the
|
||||
-- subscription selection set. The results of the execution generate a Response
|
||||
-- Stream.
|
||||
type ResponseEventStream m a = ConduitT () (Response a) m ()
|
||||
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
|
|
|
|||
|
|
@ -7,13 +7,13 @@ module Language.GraphQL.Execute
|
|||
) where
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Document (Document, Name)
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Execution
|
||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||
import qualified Language.GraphQL.Execute.Subscribe as Subscribe
|
||||
import Language.GraphQL.Error
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
|
@ -28,24 +28,28 @@ import Language.GraphQL.Type.Schema
|
|||
execute :: (Monad m, VariableValue a, Serialize b)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> HashMap.HashMap Name a -- ^ Variable substitution function.
|
||||
-> HashMap Name a -- ^ Variable substitution function.
|
||||
-> Document -- @GraphQL@ document.
|
||||
-> m (Response b)
|
||||
-> m (Either (ResponseEventStream m b) (Response b))
|
||||
execute schema operationName subs document =
|
||||
case Transform.document schema operationName subs document of
|
||||
Left queryError -> pure $ singleError $ Transform.queryError queryError
|
||||
Left queryError -> pure
|
||||
$ Right
|
||||
$ singleError
|
||||
$ Transform.queryError queryError
|
||||
Right transformed -> executeRequest transformed
|
||||
|
||||
executeRequest :: (Monad m, Serialize a)
|
||||
=> Transform.Document m
|
||||
-> m (Response a)
|
||||
-> m (Either (ResponseEventStream m a) (Response a))
|
||||
executeRequest (Transform.Document types' rootObjectType operation)
|
||||
| (Transform.Query _ fields) <- operation =
|
||||
executeOperation types' rootObjectType fields
|
||||
Right <$> executeOperation types' rootObjectType fields
|
||||
| (Transform.Mutation _ fields) <- operation =
|
||||
executeOperation types' rootObjectType fields
|
||||
| otherwise =
|
||||
pure $ singleError "This service does not support subscriptions."
|
||||
Right <$> executeOperation types' rootObjectType fields
|
||||
| (Transform.Subscription _ fields) <- operation
|
||||
= either (Right . singleError) Left
|
||||
<$> Subscribe.subscribe types' rootObjectType fields
|
||||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
|
|
|
|||
|
|
@ -3,7 +3,9 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Language.GraphQL.Execute.Execution
|
||||
( executeSelectionSet
|
||||
( coerceArgumentValues
|
||||
, collectFields
|
||||
, executeSelectionSet
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
|
|
@ -32,10 +34,10 @@ import Prelude hiding (null)
|
|||
resolveFieldValue :: Monad m
|
||||
=> Type.Value
|
||||
-> Type.Subs
|
||||
-> Type.ResolverT m a
|
||||
-> m (Either Text a)
|
||||
resolveFieldValue result args =
|
||||
flip runReaderT context . runExceptT . Type.runResolverT
|
||||
-> Type.Resolve m
|
||||
-> m (Either Text Type.Value)
|
||||
resolveFieldValue result args resolver =
|
||||
flip runReaderT context $ runExceptT resolver
|
||||
where
|
||||
context = Type.Context
|
||||
{ Type.arguments = Type.Arguments args
|
||||
|
|
@ -101,12 +103,12 @@ instanceOf objectType (AbstractUnionType unionType) =
|
|||
go unionMemberType acc = acc || objectType == unionMemberType
|
||||
|
||||
executeField :: (Monad m, Serialize a)
|
||||
=> Out.Field m
|
||||
=> Out.Resolver m
|
||||
-> Type.Value
|
||||
-> NonEmpty (Transform.Field m)
|
||||
-> CollectErrsT m a
|
||||
executeField fieldDefinition prev fields = do
|
||||
let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition
|
||||
executeField (Out.ValueResolver fieldDefinition resolver) prev fields = do
|
||||
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
|
||||
let (Transform.Field _ _ arguments' _ :| []) = fields
|
||||
case coerceArgumentValues argumentDefinitions arguments' of
|
||||
Nothing -> addErrMsg "Argument coercing failed."
|
||||
|
|
@ -115,6 +117,7 @@ executeField fieldDefinition prev fields = do
|
|||
case answer of
|
||||
Right result -> completeValue fieldType fields result
|
||||
Left errorMessage -> addErrMsg errorMessage
|
||||
executeField _ _ _ = addErrMsg "No field value resolver specified."
|
||||
|
||||
completeValue :: (Monad m, Serialize a)
|
||||
=> Out.Type m
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
module Language.GraphQL.Type
|
||||
( In.InputField(..)
|
||||
|
|
@ -6,7 +10,10 @@ module Language.GraphQL.Type
|
|||
, Out.Field(..)
|
||||
, Out.InterfaceType(..)
|
||||
, Out.ObjectType(..)
|
||||
, Out.ResolverT(..)
|
||||
, Out.Resolve
|
||||
, Out.Resolver(..)
|
||||
, Out.SourceEventStream
|
||||
, Out.Subscribe
|
||||
, Out.UnionType(..)
|
||||
, Out.argument
|
||||
, module Language.GraphQL.Type.Definition
|
||||
|
|
|
|||
|
|
@ -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 #-}
|
||||
|
||||
module Language.GraphQL.Type.Internal
|
||||
|
|
@ -36,11 +40,13 @@ collectReferencedTypes schema =
|
|||
collect traverser typeName element foundTypes
|
||||
| HashMap.member typeName foundTypes = foundTypes
|
||||
| otherwise = traverser $ HashMap.insert typeName element foundTypes
|
||||
visitFields (Out.Field _ outputType arguments _) foundTypes
|
||||
visitFields (Out.Field _ outputType arguments) foundTypes
|
||||
= traverseOutputType outputType
|
||||
$ foldr visitArguments foundTypes arguments
|
||||
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
|
||||
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
|
||||
getField (Out.ValueResolver field _) = field
|
||||
getField (Out.EventStreamResolver field _ _) = field
|
||||
traverseInputType (In.InputObjectBaseType objectType) =
|
||||
let (In.InputObjectType typeName _ inputFields) = objectType
|
||||
element = InputObjectType objectType
|
||||
|
|
@ -73,7 +79,7 @@ collectReferencedTypes schema =
|
|||
traverseObjectType objectType foundTypes =
|
||||
let (Out.ObjectType typeName _ interfaces fields) = objectType
|
||||
element = ObjectType objectType
|
||||
traverser = polymorphicTraverser interfaces fields
|
||||
traverser = polymorphicTraverser interfaces (getField <$> fields)
|
||||
in collect traverser typeName element foundTypes
|
||||
traverseInterfaceType interfaceType foundTypes =
|
||||
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
|
||||
|
|
|
|||
|
|
@ -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 PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
|
@ -12,7 +16,10 @@ module Language.GraphQL.Type.Out
|
|||
, Field(..)
|
||||
, InterfaceType(..)
|
||||
, ObjectType(..)
|
||||
, ResolverT(..)
|
||||
, Resolve
|
||||
, Subscribe
|
||||
, Resolver(..)
|
||||
, SourceEventStream
|
||||
, Type(..)
|
||||
, UnionType(..)
|
||||
, argument
|
||||
|
|
@ -25,10 +32,7 @@ module Language.GraphQL.Type.Out
|
|||
, pattern UnionBaseType
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Conduit
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks)
|
||||
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
|
||||
-- types have a name, but most importantly describe their fields.
|
||||
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
|
||||
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
|
||||
|
|
@ -74,7 +78,6 @@ data Field m = Field
|
|||
(Maybe Text) -- ^ Description.
|
||||
(Type m) -- ^ Field type.
|
||||
(HashMap Name In.Argument) -- ^ Arguments.
|
||||
(ResolverT m Value) -- ^ Resolver.
|
||||
|
||||
-- | These types may be used as output types as the result of fields.
|
||||
--
|
||||
|
|
@ -169,56 +172,41 @@ isNonNullType (NonNullUnionType _) = True
|
|||
isNonNullType (NonNullListType _) = True
|
||||
isNonNullType _ = False
|
||||
|
||||
-- | Resolution context holds resolver arguments.
|
||||
-- | Resolution context holds resolver arguments and the root value.
|
||||
data Context = Context
|
||||
{ arguments :: Arguments
|
||||
, values :: Value
|
||||
}
|
||||
|
||||
-- | Monad transformer stack used by the resolvers to provide error handling
|
||||
-- and resolution context (resolver arguments).
|
||||
-- | Monad transformer stack used by the resolvers for determining the resolved
|
||||
-- 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
|
||||
-- occurred). @m@ is an arbitrary monad, usually 'IO'.
|
||||
--
|
||||
-- Resolving a field can result in a leaf value or an object, which is
|
||||
-- represented as a list of nested resolvers, used to resolve the fields of that
|
||||
-- object.
|
||||
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 = (<|>)
|
||||
-- The resolvers aren't part of the 'Field' itself because not all fields
|
||||
-- have resolvers (interface fields don't have an implementation).
|
||||
data Resolver m
|
||||
= ValueResolver (Field m) (Resolve m)
|
||||
| EventStreamResolver (Field m) (Resolve m) (Subscribe m)
|
||||
|
||||
-- | Retrieves an argument by its name. If the argument with this name couldn't
|
||||
-- be found, returns 'Null' (i.e. the argument is assumed to
|
||||
-- be optional then).
|
||||
argument :: Monad m => Name -> ResolverT m Value
|
||||
argument :: Monad m => Name -> Resolve m
|
||||
argument argumentName = do
|
||||
argumentValue <- ResolverT $ lift $ asks $ lookupArgument . arguments
|
||||
argumentValue <- lift $ asks $ lookupArgument . arguments
|
||||
pure $ fromMaybe Null argumentValue
|
||||
where
|
||||
lookupArgument (Arguments argumentMap) =
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
resolver: lts-16.4
|
||||
resolver: lts-16.5
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ module Language.GraphQL.ExecuteSpec
|
|||
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import Data.HashMap.Strict (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 "Query" Nothing []
|
||||
$ HashMap.singleton "philosopher" philosopherField
|
||||
$ HashMap.singleton "philosopher"
|
||||
$ ValueResolver philosopherField
|
||||
$ pure $ Type.Object mempty
|
||||
where
|
||||
philosopherField
|
||||
= Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
||||
$ pure $ Type.Object mempty
|
||||
philosopherField =
|
||||
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
||||
|
||||
philosopherType :: Out.ObjectType Identity
|
||||
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
resolvers =
|
||||
[ ("firstName", firstNameField)
|
||||
, ("lastName", lastNameField)
|
||||
[ ("firstName", ValueResolver firstNameField firstNameResolver)
|
||||
, ("lastName", ValueResolver lastNameField lastNameResolver)
|
||||
]
|
||||
firstNameField
|
||||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
$ pure $ Type.String "Friedrich"
|
||||
firstNameField =
|
||||
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
firstNameResolver = pure $ Type.String "Friedrich"
|
||||
lastNameField
|
||||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
$ pure $ Type.String "Nietzsche"
|
||||
lastNameResolver = pure $ Type.String "Nietzsche"
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
|
@ -54,8 +56,9 @@ spec =
|
|||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
actual = runIdentity
|
||||
$ either parseError execute'
|
||||
actual = fromRight (singleError "")
|
||||
$ runIdentity
|
||||
$ either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName surname } }"
|
||||
in actual `shouldBe` expected
|
||||
it "merges selections" $
|
||||
|
|
@ -67,7 +70,8 @@ spec =
|
|||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
actual = runIdentity
|
||||
$ either parseError execute'
|
||||
actual = fromRight (singleError "")
|
||||
$ runIdentity
|
||||
$ either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ import Text.RawString.QQ (r)
|
|||
experimentalResolver :: Schema IO
|
||||
experimentalResolver = Schema { query = queryType, mutation = Nothing }
|
||||
where
|
||||
resolver = pure $ Int 5
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ 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 = object
|
||||
|
|
|
|||
|
|
@ -64,12 +64,14 @@ hatType = Out.ObjectType "Hat" Nothing []
|
|||
, ("circumference", circumferenceFieldType)
|
||||
]
|
||||
|
||||
circumferenceFieldType :: Out.Field IO
|
||||
circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
|
||||
circumferenceFieldType :: Out.Resolver IO
|
||||
circumferenceFieldType
|
||||
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ snd circumference
|
||||
|
||||
sizeFieldType :: Out.Field IO
|
||||
sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
sizeFieldType :: Out.Resolver IO
|
||||
sizeFieldType
|
||||
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ pure $ snd size
|
||||
|
||||
toSchema :: Text -> (Text, Value) -> Schema IO
|
||||
|
|
@ -78,17 +80,15 @@ toSchema t (_, resolve) = Schema
|
|||
where
|
||||
unionMember = if t == "Hat" then hatType else shirtType
|
||||
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
$ pure $ String "Shirt"
|
||||
garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
|
||||
$ pure resolve
|
||||
queryType =
|
||||
case t of
|
||||
"circumference" -> hatType
|
||||
"size" -> shirtType
|
||||
_ -> Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.fromList
|
||||
[ ("garment", garmentField)
|
||||
, ("__typename", typeNameField)
|
||||
[ ("garment", ValueResolver garmentField (pure resolve))
|
||||
, ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
|
||||
]
|
||||
|
||||
spec :: Spec
|
||||
|
|
|
|||
|
|
@ -15,23 +15,23 @@ import qualified Language.GraphQL.Type.Out as Out
|
|||
hatType :: Out.ObjectType IO
|
||||
hatType = Out.ObjectType "Hat" Nothing []
|
||||
$ HashMap.singleton "circumference"
|
||||
$ Out.Field Nothing (Out.NamedScalarType int) mempty
|
||||
$ pure
|
||||
$ Int 60
|
||||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 60
|
||||
|
||||
schema :: Schema IO
|
||||
schema = Schema
|
||||
(Out.ObjectType "Query" Nothing [] hatField)
|
||||
(Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
|
||||
(Out.ObjectType "Query" Nothing [] hatFieldResolver)
|
||||
(Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver)
|
||||
where
|
||||
garment = pure $ Object $ HashMap.fromList
|
||||
[ ("circumference", Int 60)
|
||||
]
|
||||
incrementField = HashMap.singleton "incrementCircumference"
|
||||
$ Out.Field Nothing (Out.NamedScalarType int) mempty
|
||||
incrementFieldResolver = HashMap.singleton "incrementCircumference"
|
||||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 61
|
||||
hatField = HashMap.singleton "garment"
|
||||
$ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
|
||||
hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
|
||||
hatFieldResolver =
|
||||
HashMap.singleton "garment" $ ValueResolver hatField garment
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
|
|
|||
|
|
@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
|
|||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||
|
||||
secretBackstory :: ResolverT Identity Text
|
||||
secretBackstory = ResolverT $ throwE "secretBackstory is secret."
|
||||
secretBackstory :: Resolve Identity
|
||||
secretBackstory = throwE "secretBackstory is secret."
|
||||
|
||||
typeName :: Character -> Text
|
||||
typeName = either (const "Droid") (const "Human")
|
||||
|
|
@ -161,10 +161,10 @@ getHero :: Int -> Character
|
|||
getHero 5 = luke
|
||||
getHero _ = artoo
|
||||
|
||||
getHuman :: Alternative f => ID -> f Character
|
||||
getHuman :: ID -> Maybe Character
|
||||
getHuman = fmap Right . getHuman'
|
||||
|
||||
getHuman' :: Alternative f => ID -> f Human
|
||||
getHuman' :: ID -> Maybe Human
|
||||
getHuman' "1000" = pure luke'
|
||||
getHuman' "1001" = pure vader
|
||||
getHuman' "1002" = pure han
|
||||
|
|
@ -172,10 +172,10 @@ getHuman' "1003" = pure leia
|
|||
getHuman' "1004" = pure tarkin
|
||||
getHuman' _ = empty
|
||||
|
||||
getDroid :: Alternative f => ID -> f Character
|
||||
getDroid :: ID -> Maybe Character
|
||||
getDroid = fmap Left . getDroid'
|
||||
|
||||
getDroid' :: Alternative f => ID -> f Droid
|
||||
getDroid' :: ID -> Maybe Droid
|
||||
getDroid' "2000" = pure threepio
|
||||
getDroid' "2001" = pure artoo'
|
||||
getDroid' _ = empty
|
||||
|
|
|
|||
|
|
@ -23,19 +23,20 @@ schema :: Schema Identity
|
|||
schema = Schema { query = queryType, mutation = Nothing }
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("hero", heroField)
|
||||
, ("human", humanField)
|
||||
, ("droid", droidField)
|
||||
[ ("hero", heroFieldResolver)
|
||||
, ("human", humanFieldResolver)
|
||||
, ("droid", droidFieldResolver)
|
||||
]
|
||||
heroArguments = HashMap.singleton "episode"
|
||||
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
||||
$ HashMap.singleton "episode"
|
||||
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
|
||||
heroField =
|
||||
Out.Field Nothing (Out.NamedObjectType heroObject) heroArguments hero
|
||||
humanArguments = HashMap.singleton "id"
|
||||
heroFieldResolver = ValueResolver heroField hero
|
||||
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
||||
$ HashMap.singleton "id"
|
||||
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
|
||||
humanField =
|
||||
Out.Field Nothing (Out.NamedObjectType heroObject) humanArguments human
|
||||
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid
|
||||
humanFieldResolver = ValueResolver humanField human
|
||||
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
|
||||
droidFieldResolver = ValueResolver droidField droid
|
||||
|
||||
heroObject :: Out.ObjectType Identity
|
||||
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
||||
|
|
@ -48,8 +49,9 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
|||
, ("__typename", typenameFieldType)
|
||||
]
|
||||
where
|
||||
homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
$ idField "homePlanet"
|
||||
homePlanetFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "homePlanet"
|
||||
|
||||
droidObject :: Out.ObjectType Identity
|
||||
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
||||
|
|
@ -62,39 +64,48 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
|||
, ("__typename", typenameFieldType)
|
||||
]
|
||||
where
|
||||
primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
primaryFunctionFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "primaryFunction"
|
||||
|
||||
typenameFieldType :: Out.Field Identity
|
||||
typenameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
typenameFieldType :: Resolver Identity
|
||||
typenameFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "__typename"
|
||||
|
||||
idFieldType :: Out.Field Identity
|
||||
idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
|
||||
idFieldType :: Resolver Identity
|
||||
idFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
|
||||
$ idField "id"
|
||||
|
||||
nameFieldType :: Out.Field Identity
|
||||
nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
nameFieldType :: Resolver Identity
|
||||
nameFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "name"
|
||||
|
||||
friendsFieldType :: Out.Field Identity
|
||||
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
|
||||
friendsFieldType :: Resolver Identity
|
||||
friendsFieldType
|
||||
= ValueResolver (Out.Field Nothing fieldType mempty)
|
||||
$ idField "friends"
|
||||
where
|
||||
fieldType = Out.ListType $ Out.NamedObjectType droidObject
|
||||
|
||||
appearsInField :: Out.Field Identity
|
||||
appearsInField = Out.Field (Just description) fieldType mempty
|
||||
appearsInField :: Resolver Identity
|
||||
appearsInField
|
||||
= ValueResolver (Out.Field (Just description) fieldType mempty)
|
||||
$ idField "appearsIn"
|
||||
where
|
||||
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
|
||||
description = "Which movies they appear in."
|
||||
|
||||
secretBackstoryFieldType :: Out.Field Identity
|
||||
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
$ String <$> secretBackstory
|
||||
secretBackstoryFieldType :: Resolver Identity
|
||||
secretBackstoryFieldType = ValueResolver field secretBackstory
|
||||
where
|
||||
field = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
|
||||
idField :: Text -> ResolverT Identity Value
|
||||
idField :: Text -> Resolve Identity
|
||||
idField f = do
|
||||
v <- ResolverT $ lift $ asks values
|
||||
v <- lift $ asks values
|
||||
let (Object v') = v
|
||||
pure $ v' HashMap.! f
|
||||
|
||||
|
|
@ -107,7 +118,7 @@ episodeEnum = EnumType "Episode" (Just description)
|
|||
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
|
||||
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
|
||||
|
||||
hero :: ResolverT Identity Value
|
||||
hero :: Resolve Identity
|
||||
hero = do
|
||||
episode <- argument "episode"
|
||||
pure $ character $ case episode of
|
||||
|
|
@ -116,23 +127,19 @@ hero = do
|
|||
Enum "JEDI" -> getHero 6
|
||||
_ -> artoo
|
||||
|
||||
human :: ResolverT Identity Value
|
||||
human :: Resolve Identity
|
||||
human = do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
String i -> do
|
||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||
case humanCharacter of
|
||||
Nothing -> pure Null
|
||||
Just e -> pure $ character e
|
||||
_ -> ResolverT $ throwE "Invalid arguments."
|
||||
String i -> pure $ maybe Null character $ getHuman i >>= Just
|
||||
_ -> throwE "Invalid arguments."
|
||||
|
||||
droid :: ResolverT Identity Value
|
||||
droid :: Resolve Identity
|
||||
droid = do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
String i -> character <$> getDroid i
|
||||
_ -> ResolverT $ throwE "Invalid arguments."
|
||||
String i -> pure $ maybe Null character $ getDroid i >>= Just
|
||||
_ -> throwE "Invalid arguments."
|
||||
|
||||
character :: Character -> Value
|
||||
character char = Object $ HashMap.fromList
|
||||
|
|
|
|||
Loading…
Reference in New Issue