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.
- `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`.

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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.

View File

@ -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

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.
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

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 #-}
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

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 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) =

View File

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

View File

@ -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
where
philosopherField
= Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
$ HashMap.singleton "philosopher"
$ ValueResolver philosopherField
$ pure $ Type.Object mempty
where
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
philosopherType :: Out.ObjectType Identity
philosopherType = Out.ObjectType "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

View File

@ -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

View File

@ -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

View File

@ -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 =

View File

@ -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

View File

@ -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,7 +49,8 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
, ("__typename", typenameFieldType)
]
where
homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
homePlanetFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "homePlanet"
droidObject :: Out.ObjectType Identity
@ -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