diff options
Diffstat (limited to 'src/Language')
| -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 |
8 files changed, 179 insertions, 69 deletions
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) = |