diff options
| -rw-r--r-- | CHANGELOG.md | 15 | ||||
| -rw-r--r-- | graphql.cabal | 7 | ||||
| -rw-r--r-- | package.yaml | 3 | ||||
| -rw-r--r-- | src/Language/GraphQL.hs | 12 | ||||
| -rw-r--r-- | src/Language/GraphQL/Error.hs | 8 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 22 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 19 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Subscribe.hs | 92 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type.hs | 9 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Internal.hs | 10 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Out.hs | 76 | ||||
| -rw-r--r-- | stack.yaml | 2 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 32 | ||||
| -rw-r--r-- | tests/Test/DirectiveSpec.hs | 4 | ||||
| -rw-r--r-- | tests/Test/FragmentSpec.hs | 16 | ||||
| -rw-r--r-- | tests/Test/RootOperationSpec.hs | 18 | ||||
| -rw-r--r-- | tests/Test/StarWars/Data.hs | 12 | ||||
| -rw-r--r-- | tests/Test/StarWars/Schema.hs | 87 |
18 files changed, 287 insertions, 157 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 862667c..224f936 100644 --- a/CHANGELOG.md +++ b/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`. diff --git a/graphql.cabal b/graphql.cabal index e7ac249..5f3c8ea 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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 diff --git a/package.yaml b/package.yaml index 88b238c..1c855e1 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 845d5cf..6ee2dd7 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -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 diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 3dbc696..474ddc7 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -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) diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 471cd00..08aa5ab 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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. diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index e9ba4a7..fe4ad82 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs new file mode 100644 index 0000000..ee9b116 --- /dev/null +++ b/src/Language/GraphQL/Execute/Subscribe.hs @@ -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 diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index 0a30924..e84fc03 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -1,3 +1,7 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + -- | 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 diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 07dabe6..9121d13 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -1,3 +1,7 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + {-# LANGUAGE 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 diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 97107ca..d094b4d 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -1,3 +1,7 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + {-# LANGUAGE 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). --- --- 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 +-- | Monad transformer stack used by the resolvers for determining the resolved +-- value of a field. +type Resolve m = ExceptT Text (ReaderT Context m) Value -instance MonadTrans ResolverT where - lift = ResolverT . lift . lift +-- | 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) -instance MonadIO m => MonadIO (ResolverT m) where - liftIO = lift . liftIO +-- | 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 () -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 = (<|>) +-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver' +-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves +-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a +-- root subscription type. +-- +-- The resolvers aren't part of the 'Field' itself because not all fields +-- have resolvers (interface fields don't have an implementation). +data Resolver m + = ValueResolver (Field m) (Resolve m) + | EventStreamResolver (Field m) (Resolve m) (Subscribe m) -- | Retrieves an argument by its name. If the argument with this name couldn't -- be found, returns 'Null' (i.e. the argument is assumed to -- be optional then). -argument :: Monad m => Name -> 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: - . diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index e7ab9f8..f994482 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -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 diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 3243d2a..4d31cb9 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 94cc76c..af1812c 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 44b19a6..7202104 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 = diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index dacd0cd..00a89d9 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index cf18eca..ed3c32c 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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." - -droid :: ResolverT Identity Value + String i -> pure $ maybe Null character $ getHuman i >>= Just + _ -> throwE "Invalid arguments." + +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 |