diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 62754a3..1ccdee0 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,71 +1,861 @@ -{-# LANGUAGE ExplicitForAll #-} +{- 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 ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute - ( execute - , module Language.GraphQL.Execute.Coerce - ) where + ( Error(..) + , Operation(..) + , Path(..) + , Response(..) + , execute + ) where -import Control.Monad.Catch (MonadCatch) -import Data.HashMap.Strict (HashMap) -import Data.Sequence (Seq(..)) -import Data.Text (Text) +import Conduit (mapMC, (.|)) +import Control.Arrow (left) +import Control.Monad.Catch + ( Exception(..) + , MonadCatch(..) + , MonadThrow(..) + , SomeException(..) + ) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT) +import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell) +import qualified Control.Monad.Trans.Reader as Reader +import Control.Monad (foldM) import qualified Language.GraphQL.AST.Document as Full -import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Execution -import Language.GraphQL.Execute.Internal -import qualified Language.GraphQL.Execute.Transform as Transform -import qualified Language.GraphQL.Execute.Subscribe as Subscribe -import Language.GraphQL.Error - ( Error - , ResponseEventStream - , Response(..) - , runCollectErrs - ) -import qualified Language.GraphQL.Type.Definition as Definition +import Data.Bifunctor (first) +import Data.Foldable (find) +import Data.Functor ((<&>)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe, isJust) +import Data.Sequence (Seq, (><)) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (cast) +import qualified Language.GraphQL.Execute.Coerce as Coerce +import Language.GraphQL.Execute.OrderedMap (OrderedMap) +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap +import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema -import Prelude hiding (null) +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.Internal as Type.Internal +import Language.GraphQL.Type.Schema (Schema, Type) +import qualified Language.GraphQL.Type.Schema as Schema +import Language.GraphQL.Error + ( Error(..) + , Response(..) + , Path(..) + , ResponseEventStream + ) --- | The substitution is applied to the document, and the resolvers are applied --- to the resulting fields. The operation name can be used if the document --- defines multiple root operations. --- --- Returns the result of the query against the schema wrapped in a /data/ --- field, or errors wrapped in an /errors/ field. -execute :: (MonadCatch m, VariableValue a, Serialize b) +data Replacement m = Replacement + { variableValues :: Type.Subs + , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition + , visitedFragments :: HashSet Full.Name + , types :: HashMap Full.Name (Type m) + } + +newtype TransformT m a = TransformT + { runTransformT :: ReaderT (Replacement m) m a + } + +instance Functor m => Functor (TransformT m) where + fmap f = TransformT . fmap f . runTransformT + +instance Applicative m => Applicative (TransformT m) where + pure = TransformT . pure + TransformT f <*> TransformT x = TransformT $ f <*> x + +instance Monad m => Monad (TransformT m) where + TransformT x >>= f = TransformT $ x >>= runTransformT . f + +instance MonadTrans TransformT where + lift = TransformT . lift + +instance MonadThrow m => MonadThrow (TransformT m) where + throwM = lift . throwM + +instance MonadCatch m => MonadCatch (TransformT m) where + catch (TransformT stack) handler = + TransformT $ catch stack $ runTransformT . handler + +newtype ExecutorT m a = ExecutorT + { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a + } + +instance Functor m => Functor (ExecutorT m) where + fmap f = ExecutorT . fmap f . runExecutorT + +instance Applicative m => Applicative (ExecutorT m) where + pure = ExecutorT . pure + ExecutorT f <*> ExecutorT x = ExecutorT $ f <*> x + +instance Monad m => Monad (ExecutorT m) where + ExecutorT x >>= f = ExecutorT $ x >>= runExecutorT . f + +instance MonadTrans ExecutorT where + lift = ExecutorT . lift . lift + +instance MonadThrow m => MonadThrow (ExecutorT m) where + throwM = lift . throwM + +instance MonadCatch m => MonadCatch (ExecutorT m) where + catch (ExecutorT stack) handler = + ExecutorT $ catch stack $ runExecutorT . handler + +data GraphQLException = forall e. Exception e => GraphQLException e + +instance Show GraphQLException where + show (GraphQLException e) = show e + +instance Exception GraphQLException + +graphQLExceptionToException :: Exception e => e -> SomeException +graphQLExceptionToException = toException . GraphQLException + +graphQLExceptionFromException :: Exception e => SomeException -> Maybe e +graphQLExceptionFromException e = do + GraphQLException graphqlException <- fromException e + cast graphqlException + +data ResolverException = forall e. Exception e => ResolverException e + +instance Show ResolverException where + show (ResolverException e) = show e + +instance Exception ResolverException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +data FieldError + = ArgumentTypeError + | MissingArgumentError + | ResultCoercionError + | NullResultError + +instance Show FieldError where + show ArgumentTypeError = "Invalid argument type." + show MissingArgumentError = "Required argument not specified." + show ResultCoercionError = "Result coercion failed." + show NullResultError = "Non-Nullable field resolver returned Null." + +newtype FieldException = FieldException FieldError + deriving Show + +instance Exception FieldException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +data ValueCompletionException = ValueCompletionException String Type.Value + +instance Show ValueCompletionException where + show (ValueCompletionException typeRepresentation found) = concat + [ "Value completion error. Expected type " + , typeRepresentation + , ", found: " + , show found + , "." + ] + +instance Exception ValueCompletionException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +data QueryError + = OperationNameRequired + | OperationNotFound String + | CoercionError Full.VariableDefinition + | UnknownInputType Full.VariableDefinition + +asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a +asks = TransformT . Reader.asks + +queryError :: QueryError -> Error +queryError OperationNameRequired = + Error{ message = "Operation name is required.", locations = [], path = [] } +queryError (OperationNotFound operationName) = + let queryErrorMessage = Text.concat + [ "Operation \"" + , Text.pack operationName + , "\" not found." + ] + in Error{ message = queryErrorMessage, locations = [], path = [] } +queryError (CoercionError variableDefinition) = + let Full.VariableDefinition variableName _ _ location = variableDefinition + queryErrorMessage = Text.concat + [ "Failed to coerce the variable \"" + , variableName + , "\"." + ] + in Error{ message = queryErrorMessage, locations = [location], path = [] } +queryError (UnknownInputType variableDefinition) = + let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition + queryErrorMessage = Text.concat + [ "Variable \"" + , variableName + , "\" has unknown type \"" + , Text.pack $ show variableTypeName + , "\"." + ] + in Error{ message = queryErrorMessage, locations = [location], path = [] } + +data Operation m + = Operation Full.OperationType (Seq (Selection m)) Full.Location + +data Selection m + = FieldSelection (Field m) + | FragmentSelection (Fragment m) + +data Field m = Field + (Maybe Full.Name) + Full.Name + (HashMap Full.Name (Full.Node Input)) + (Seq (Selection m)) + Full.Location + +data Fragment m = Fragment + (Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location + +data Input + = Variable Type.Value + | Int Int32 + | Float Double + | String Text + | Boolean Bool + | Null + | Enum Full.Name + | List [Input] + | Object (HashMap Full.Name Input) + +document :: Full.Document + -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition) +document = foldr filterOperation ([], HashMap.empty) + where + filterOperation (Full.ExecutableDefinition executableDefinition) accumulator + | Full.DefinitionOperation operationDefinition' <- executableDefinition = + first (operationDefinition' :) accumulator + | Full.DefinitionFragment fragmentDefinition <- executableDefinition + , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition = + HashMap.insert fragmentName fragmentDefinition <$> accumulator + filterOperation _ accumulator = accumulator -- Type system definitions. + +transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m) +transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do + transformedSelections <- selectionSet selectionSet' + pure $ Operation operationType transformedSelections operationLocation +transform (Full.SelectionSet selectionSet' operationLocation) = do + transformedSelections <- selectionSet selectionSet' + pure $ Operation Full.Query transformedSelections operationLocation + +selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m)) +selectionSet = selectionSetOpt . NonEmpty.toList + +selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m)) +selectionSetOpt = foldM go Seq.empty + where + go accumulatedSelections currentSelection = + selection currentSelection <&> (accumulatedSelections ><) + +selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m)) +selection (Full.FieldSelection field') = + maybeToSelectionSet FieldSelection $ field field' +selection (Full.FragmentSpreadSelection fragmentSpread') = + maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread' +selection (Full.InlineFragmentSelection inlineFragment') = + either id (pure . FragmentSelection) <$> inlineFragment inlineFragment' + +maybeToSelectionSet :: Monad m + => forall a + . (a -> Selection m) + -> TransformT m (Maybe a) + -> TransformT m (Seq (Selection m)) +maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType) + +directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive]) +directives = fmap Type.selection . traverse directive + +inlineFragment :: Monad m + => Full.InlineFragment + -> TransformT m (Either (Seq (Selection m)) (Fragment m)) +inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location) + | Just typeCondition <- maybeCondition = do + transformedSelections <- selectionSet selectionSet' + transformedDirectives <- directives directives' + maybeFragmentType <- asks + $ Type.Internal.lookupTypeCondition typeCondition + . types + pure $ case transformedDirectives >> maybeFragmentType of + Just fragmentType -> Right + $ Fragment fragmentType transformedSelections location + Nothing -> Left Seq.empty + | otherwise = do + transformedSelections <- selectionSet selectionSet' + transformedDirectives <- directives directives' + pure $ if isJust transformedDirectives + then Left transformedSelections + else Left Seq.empty + +fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m)) +fragmentSpread (Full.FragmentSpread spreadName directives' location) = do + transformedDirectives <- directives directives' + visitedFragment <- asks $ HashSet.member spreadName . visitedFragments + possibleFragmentDefinition <- asks + $ HashMap.lookup spreadName + . fragmentDefinitions + case transformedDirectives >> possibleFragmentDefinition of + Just (Full.FragmentDefinition _ typeCondition _ selections _) + | visitedFragment -> pure Nothing + | otherwise -> do + fragmentType <- asks + $ Type.Internal.lookupTypeCondition typeCondition + . types + traverse (traverseSelections selections) fragmentType + Nothing -> pure Nothing + where + traverseSelections selections typeCondition = do + transformedSelections <- TransformT + $ local fragmentInserter + $ runTransformT + $ selectionSet selections + pure $ Fragment typeCondition transformedSelections location + fragmentInserter replacement@Replacement{ visitedFragments } = replacement + { visitedFragments = HashSet.insert spreadName visitedFragments } + +field :: Monad m => Full.Field -> TransformT m (Maybe (Field m)) +field (Full.Field alias' name' arguments' directives' selectionSet' location') = do + transformedSelections <- selectionSetOpt selectionSet' + transformedDirectives <- directives directives' + transformedArguments <- arguments arguments' + let transformedField = Field + alias' + name' + transformedArguments + transformedSelections + location' + pure $ transformedDirectives >> pure transformedField + +arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input)) +arguments = foldM go HashMap.empty + where + go accumulator (Full.Argument name' valueNode _) = do + argumentValue <- node valueNode + pure $ insertIfGiven name' argumentValue accumulator + +directive :: Monad m => Full.Directive -> TransformT m Type.Directive +directive (Full.Directive name' arguments' _) + = Type.Directive name' + . Type.Arguments + <$> foldM go HashMap.empty arguments' + where + go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do + transformedValue <- directiveValue node' + pure $ HashMap.insert argumentName transformedValue accumulator + +directiveValue :: Monad m => Full.Value -> TransformT m Type.Value +directiveValue = \case + (Full.Variable name') -> asks + $ HashMap.lookupDefault Type.Null name' + . variableValues + (Full.Int integer) -> pure $ Type.Int integer + (Full.Float double) -> pure $ Type.Float double + (Full.String string) -> pure $ Type.String string + (Full.Boolean boolean) -> pure $ Type.Boolean boolean + Full.Null -> pure Type.Null + (Full.Enum enum) -> pure $ Type.Enum enum + (Full.List list) -> Type.List <$> traverse directiveNode list + (Full.Object objectFields) -> + Type.Object <$> foldM objectField HashMap.empty objectFields + where + directiveNode Full.Node{ node = node'} = directiveValue node' + objectField accumulator Full.ObjectField{ name, value } = do + transformedValue <- directiveNode value + pure $ HashMap.insert name transformedValue accumulator + +input :: Monad m => Full.Value -> TransformT m (Maybe Input) +input (Full.Variable name') = + asks (HashMap.lookup name' . variableValues) <&> fmap Variable +input (Full.Int integer) = pure $ Just $ Int integer +input (Full.Float double) = pure $ Just $ Float double +input (Full.String string) = pure $ Just $ String string +input (Full.Boolean boolean) = pure $ Just $ Boolean boolean +input Full.Null = pure $ Just Null +input (Full.Enum enum) = pure $ Just $ Enum enum +input (Full.List list) = Just . List + <$> traverse (fmap (fromMaybe Null) . input . Full.node) list +input (Full.Object objectFields) = Just . Object + <$> foldM objectField HashMap.empty objectFields + where + objectField accumulator Full.ObjectField{..} = do + objectFieldValue <- fmap Full.node <$> node value + pure $ insertIfGiven name objectFieldValue accumulator + +insertIfGiven :: forall a + . Full.Name + -> Maybe a + -> HashMap Full.Name a + -> HashMap Full.Name a +insertIfGiven name (Just v) = HashMap.insert name v +insertIfGiven _ _ = id + +node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input)) +node Full.Node{node = node', ..} = + traverse Full.Node <$> input node' <*> pure location + +execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b) => Schema m -- ^ Resolvers. -> Maybe Text -- ^ Operation name. -> HashMap Full.Name a -- ^ Variable substitution function. -> Full.Document -- @GraphQL@ document. -> m (Either (ResponseEventStream m b) (Response b)) -execute schema' operationName subs document - = either (pure . rightErrorResponse . singleError [] . show) executeRequest - $ Transform.document schema' operationName subs document +execute schema' operationName subs document' = + executeRequest schema' document' (Text.unpack <$> operationName) subs -executeRequest :: (MonadCatch m, Serialize a) - => Transform.Document m +executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b) + => Schema m + -> Full.Document + -> Maybe String + -> HashMap Full.Name b -> m (Either (ResponseEventStream m a) (Response a)) -executeRequest (Transform.Document types' rootObjectType operation) - | (Transform.Query _ fields objectLocation) <- operation = - Right <$> executeOperation types' rootObjectType objectLocation fields - | (Transform.Mutation _ fields objectLocation) <- operation = - Right <$> executeOperation types' rootObjectType objectLocation fields - | (Transform.Subscription _ fields objectLocation) <- operation - = either rightErrorResponse Left - <$> Subscribe.subscribe types' rootObjectType objectLocation fields +executeRequest schema sourceDocument operationName variableValues = do + operationAndVariables <- sequence buildOperation + case operationAndVariables of + Left queryError' -> pure + $ Right + $ Response Coerce.null $ pure $ queryError queryError' + Right operation + | Operation Full.Query topSelections _operationLocation <- operation -> + Right <$> executeQuery topSelections schema + | Operation Full.Mutation topSelections operationLocation <- operation -> + Right <$> executeMutation topSelections schema operationLocation + | Operation Full.Subscription topSelections operationLocation <- operation -> + either rightErrorResponse Left <$> subscribe topSelections schema operationLocation + where + schemaTypes = Schema.types schema + (operationDefinitions, fragmentDefinitions') = document sourceDocument + buildOperation = do + operationDefinition <- getOperation operationDefinitions operationName + coercedVariableValues <- coerceVariableValues + schemaTypes + operationDefinition + variableValues + let replacement = Replacement + { variableValues = coercedVariableValues + , fragmentDefinitions = fragmentDefinitions' + , visitedFragments = mempty + , types = schemaTypes + } + pure $ flip runReaderT replacement + $ runTransformT + $ transform operationDefinition --- This is actually executeMutation, but we don't distinguish between queries --- and mutations yet. -executeOperation :: (MonadCatch m, Serialize a) +rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b) +rightErrorResponse = Right . Response Coerce.null . pure + +getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition +getOperation [operation] Nothing = Right operation +getOperation operations (Just givenOperationName) + = maybe (Left $ OperationNotFound givenOperationName) Right + $ find findOperationByName operations + where + findOperationByName (Full.OperationDefinition _ (Just operationName) _ _ _ _) = + givenOperationName == Text.unpack operationName + findOperationByName _ = False +getOperation _ _ = Left OperationNameRequired + +executeQuery :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) + -> Schema m + -> m (Response a) +executeQuery topSelections schema = do + let queryType = Schema.query schema + (data', errors) <- runWriterT + $ flip runReaderT (Schema.types schema) + $ runExecutorT + $ executeSelectionSet topSelections queryType Type.Null [] + pure $ Response data' errors + +executeMutation :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) + -> Schema m + -> Full.Location + -> m (Response a) +executeMutation topSelections schema operationLocation + | Just mutationType <- Schema.mutation schema = do + (data', errors) <- runWriterT + $ flip runReaderT (Schema.types schema) + $ runExecutorT + $ executeSelectionSet topSelections mutationType Type.Null [] + pure $ Response data' errors + | otherwise = pure + $ Response Coerce.null + $ Seq.singleton + $ Error "Schema doesn't support mutations." [operationLocation] [] + +executeSelectionSet :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) + -> Out.ObjectType m + -> Type.Value + -> [Path] + -> ExecutorT m a +executeSelectionSet selections objectType objectValue errorPath = do + let groupedFieldSet = collectFields objectType selections + resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet + coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues + where + executeField' fields resolver = + executeField objectValue fields resolver errorPath + Out.ObjectType _ _ _ resolvers = objectType + go fields@(Field _ fieldName _ _ _ :| _) = + traverse (executeField' fields) $ HashMap.lookup fieldName resolvers + +fieldsSegment :: forall m. NonEmpty (Field m) -> Path +fieldsSegment (Field alias fieldName _ _ _ :| _) = + Segment (fromMaybe fieldName alias) + +executeField :: (MonadCatch m, Coerce.Serialize a) + => Type.Value + -> NonEmpty (Field m) + -> Out.Resolver m + -> [Path] + -> ExecutorT m a +executeField objectValue fields resolver errorPath = + let Field _ fieldName inputArguments _ fieldLocation :| _ = fields + in catch (go fieldName inputArguments) $ exceptionHandler fieldLocation + where + exceptionHandler :: (MonadCatch m, Coerce.Serialize a) + => Full.Location + -> GraphQLException + -> ExecutorT m a + exceptionHandler fieldLocation e = + let newError = Error (Text.pack $ displayException e) [fieldLocation] errorPath + in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null + go fieldName inputArguments = do + let (Out.Field _ fieldType argumentTypes, resolveFunction) = + resolverField resolver + argumentValues <- coerceArgumentValues argumentTypes inputArguments + resolvedValue <- + resolveFieldValue resolveFunction objectValue fieldName argumentValues + completeValue fieldType fields errorPath resolvedValue + resolverField (Out.ValueResolver resolverField' resolveFunction) = + (resolverField', resolveFunction) + resolverField (Out.EventStreamResolver resolverField' resolveFunction _) = + (resolverField', resolveFunction) + +resolveFieldValue :: MonadCatch m + => Out.Resolve m + -> Type.Value + -> Full.Name + -> Type.Subs + -> ExecutorT m Type.Value +resolveFieldValue resolver objectValue _fieldName argumentValues = + lift $ runReaderT resolver context + where + context = Type.Context + { Type.arguments = Type.Arguments argumentValues + , Type.values = objectValue + } + +resolveAbstractType :: Monad m + => Type.Internal.AbstractType m + -> Type.Subs + -> ExecutorT m (Maybe (Out.ObjectType m)) +resolveAbstractType abstractType values' + | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do + types' <- ExecutorT ask + case HashMap.lookup typeName types' of + Just (Type.Internal.ObjectType objectType) -> + if Type.Internal.instanceOf objectType abstractType + then pure $ Just objectType + else pure Nothing + _ -> pure Nothing + | otherwise = pure Nothing + +completeValue :: (MonadCatch m, Coerce.Serialize a) + => Out.Type m + -> NonEmpty (Field m) + -> [Path] + -> Type.Value + -> ExecutorT m a +completeValue outputType _ _ Type.Null + | Out.isNonNullType outputType = throwFieldError NullResultError + | otherwise = pure Coerce.null +completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list) + = foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd + where + go (index, accumulator) listItem = do + let updatedPath = Index index : errorPath + completedValue <- completeValue listType fields updatedPath listItem + pure (index + 1, completedValue : accumulator) +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) = + coerceResult outputType $ Coerce.Int int +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) = + coerceResult outputType $ Coerce.Boolean boolean +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) = + coerceResult outputType $ Coerce.Float float +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) = + coerceResult outputType $ Coerce.String string +completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) = + let Type.EnumType _ _ enumMembers = enumType + in if HashMap.member enum enumMembers + then coerceResult outputType $ Coerce.Enum enum + else throwM + $ ValueCompletionException (show outputType) + $ Type.Enum enum +completeValue (Out.ObjectBaseType objectType) fields errorPath result + = executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath +completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result + | Type.Object objectMap <- result = do + let abstractType = Type.Internal.AbstractInterfaceType interfaceType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType + -> executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath + Nothing -> throwM + $ ValueCompletionException (show outputType) result +completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result + | Type.Object objectMap <- result = do + let abstractType = Type.Internal.AbstractUnionType unionType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType + -> executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath + Nothing -> throwM + $ ValueCompletionException (show outputType) result +completeValue outputType _ _ result = + throwM $ ValueCompletionException (show outputType) result + +coerceResult :: (MonadCatch m, Coerce.Serialize a) + => Out.Type m + -> Coerce.Output a + -> ExecutorT m a +coerceResult outputType result + | Just serialized <- Coerce.serialize outputType result = pure serialized + | otherwise = throwFieldError ResultCoercionError + +mergeSelectionSets :: MonadCatch m + => NonEmpty (Field m) + -> Seq (Selection m) +mergeSelectionSets = foldr forEach mempty + where + forEach (Field _ _ _ fieldSelectionSet _) selectionSet' = + selectionSet' <> fieldSelectionSet + +throwFieldError :: MonadCatch m => FieldError -> m a +throwFieldError = throwM . FieldException + +coerceArgumentValues :: MonadCatch m + => HashMap Full.Name In.Argument + -> HashMap Full.Name (Full.Node Input) + -> m Type.Subs +coerceArgumentValues argumentDefinitions argumentValues = + HashMap.foldrWithKey c pure argumentDefinitions mempty + where + c argumentName argumentType pure' resultMap = + forEach argumentName argumentType resultMap >>= pure' + forEach :: MonadCatch m + => Full.Name + -> In.Argument + -> Type.Subs + -> m Type.Subs + forEach argumentName (In.Argument _ variableType defaultValue) resultMap = do + let matchedMap + = matchFieldValues' argumentName variableType defaultValue + $ Just resultMap + in case matchedMap of + Just matchedValues -> pure matchedValues + Nothing + | Just _ <- HashMap.lookup argumentName argumentValues -> + throwFieldError ArgumentTypeError + | otherwise -> throwFieldError MissingArgumentError + matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue + $ Full.node <$> argumentValues + coerceArgumentValue inputType (Int integer) = + Coerce.coerceInputLiteral inputType (Type.Int integer) + coerceArgumentValue inputType (Boolean boolean) = + Coerce.coerceInputLiteral inputType (Type.Boolean boolean) + coerceArgumentValue inputType (String string) = + Coerce.coerceInputLiteral inputType (Type.String string) + coerceArgumentValue inputType (Float float) = + Coerce.coerceInputLiteral inputType (Type.Float float) + coerceArgumentValue inputType (Enum enum) = + Coerce.coerceInputLiteral inputType (Type.Enum enum) + coerceArgumentValue inputType Null + | In.isNonNullType inputType = Nothing + | otherwise = Coerce.coerceInputLiteral inputType Type.Null + coerceArgumentValue (In.ListBaseType inputType) (List list) = + let coerceItem = coerceArgumentValue inputType + in Type.List <$> traverse coerceItem list + coerceArgumentValue (In.InputObjectBaseType inputType) (Object object) + | In.InputObjectType _ _ inputFields <- inputType = + let go = forEachField object + resultMap = HashMap.foldrWithKey go (pure mempty) inputFields + in Type.Object <$> resultMap + coerceArgumentValue _ (Variable variable) = pure variable + coerceArgumentValue _ _ = Nothing + forEachField object variableName (In.InputField _ variableType defaultValue) = + Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue + +collectFields :: Monad m + => Out.ObjectType m + -> Seq (Selection m) + -> OrderedMap (NonEmpty (Field m)) +collectFields objectType = foldl forEach OrderedMap.empty + where + forEach groupedFields (FieldSelection fieldSelection) = + let Field maybeAlias fieldName _ _ _ = fieldSelection + responseKey = fromMaybe fieldName maybeAlias + in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields + forEach groupedFields (FragmentSelection selectionFragment) + | Fragment fragmentType fragmentSelectionSet _ <- selectionFragment + , Type.Internal.doesFragmentTypeApply fragmentType objectType = + let fragmentGroupedFieldSet = + collectFields objectType fragmentSelectionSet + in groupedFields <> fragmentGroupedFieldSet + | otherwise = groupedFields + +coerceVariableValues :: (Monad m, Coerce.VariableValue b) + => HashMap Full.Name (Schema.Type m) + -> Full.OperationDefinition + -> HashMap Full.Name b + -> Either QueryError Type.Subs +coerceVariableValues types operationDefinition' variableValues + | Full.OperationDefinition _ _ variableDefinitions _ _ _ <- + operationDefinition' + = foldr forEach (Right HashMap.empty) variableDefinitions + | otherwise = pure mempty + where + forEach variableDefinition (Right coercedValues) = + let Full.VariableDefinition variableName variableTypeName defaultValue _ = + variableDefinition + defaultValue' = constValue . Full.node <$> defaultValue + in case Type.Internal.lookupInputType variableTypeName types of + Just variableType -> + maybe (Left $ CoercionError variableDefinition) Right + $ Coerce.matchFieldValues + coerceVariableValue' + variableValues + variableName + variableType + defaultValue' + $ Just coercedValues + Nothing -> Left $ UnknownInputType variableDefinition + forEach _ coercedValuesOrError = coercedValuesOrError + coerceVariableValue' variableType value' + = Coerce.coerceVariableValue variableType value' + >>= Coerce.coerceInputLiteral variableType + +constValue :: Full.ConstValue -> Type.Value +constValue (Full.ConstInt i) = Type.Int i +constValue (Full.ConstFloat f) = Type.Float f +constValue (Full.ConstString x) = Type.String x +constValue (Full.ConstBoolean b) = Type.Boolean b +constValue Full.ConstNull = Type.Null +constValue (Full.ConstEnum e) = Type.Enum e +constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list +constValue (Full.ConstObject o) = + Type.Object $ HashMap.fromList $ constObjectField <$> o + where + constObjectField Full.ObjectField{value = value', ..} = + (name, constValue $ Full.node value') + +subscribe :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) + -> Schema m + -> Full.Location + -> m (Either Error (ResponseEventStream m a)) +subscribe fields schema objectLocation + | Just objectType <- Schema.subscription schema = do + let types' = Schema.types schema + sourceStream <- + createSourceEventStream types' objectType objectLocation fields + let traverser = + mapSourceToResponseEvent types' objectType fields + traverse traverser sourceStream + | otherwise = pure $ Left + $ Error "Schema doesn't support subscriptions." [] [] + +mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a) + => HashMap Full.Name (Type m) + -> Out.ObjectType m + -> Seq (Selection m) + -> Out.SourceEventStream m + -> m (ResponseEventStream m a) +mapSourceToResponseEvent types' subscriptionType fields sourceStream + = pure + $ sourceStream + .| mapMC (executeSubscriptionEvent types' subscriptionType fields) + +createSourceEventStream :: MonadCatch m => HashMap Full.Name (Type m) -> Out.ObjectType m -> Full.Location - -> Seq (Transform.Selection m) - -> m (Response a) -executeOperation types' objectType objectLocation fields - = runCollectErrs types' - $ executeSelectionSet Definition.Null objectType objectLocation fields + -> Seq (Selection m) + -> m (Either Error (Out.SourceEventStream m)) +createSourceEventStream _types subscriptionType objectLocation fields + | [fieldGroup] <- OrderedMap.elems groupedFieldSet + , Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup + , Out.ObjectType _ _ _ fieldTypes <- subscriptionType + , resolverT <- fieldTypes HashMap.! fieldName + , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT + , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition = + case coerceArgumentValues argumentDefinitions arguments' of + Left _ -> pure + $ Left + $ Error "Argument coercion failed." [errorLocation] [] + Right argumentValues -> left (singleError' [errorLocation]) + <$> resolveFieldEventStream Type.Null argumentValues resolver + | otherwise = pure + $ Left + $ Error "Subscription contains more than one field." [objectLocation] [] + where + groupedFieldSet = collectFields subscriptionType fields -rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b) -rightErrorResponse = Right . Response null . pure +singleError' :: [Full.Location] -> String -> Error +singleError' errorLocations message = Error (Text.pack message) errorLocations [] + +resolveFieldEventStream :: MonadCatch m + => Type.Value + -> Type.Subs + -> Out.Subscribe m + -> m (Either String (Out.SourceEventStream m)) +resolveFieldEventStream result args resolver = + catch (Right <$> runReaderT resolver context) handleEventStreamError + where + handleEventStreamError :: MonadCatch m + => ResolverException + -> m (Either String (Out.SourceEventStream m)) + handleEventStreamError = pure . Left . displayException + context = Type.Context + { Type.arguments = Type.Arguments args + , Type.values = result + } + +executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a) + => HashMap Full.Name (Type m) + -> Out.ObjectType m + -> Seq (Selection m) + -> Type.Value + -> m (Response a) +executeSubscriptionEvent types' objectType fields initialValue = do + (data', errors) <- runWriterT + $ flip runReaderT types' + $ runExecutorT + $ executeSelectionSet fields objectType initialValue [] + pure $ Response data' errors