diff --git a/src/Language/GraphQL/Executor.hs b/src/Language/GraphQL/Executor.hs index 02901de..ea19bd3 100644 --- a/src/Language/GraphQL/Executor.hs +++ b/src/Language/GraphQL/Executor.hs @@ -2,9 +2,10 @@ 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 ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Language.GraphQL.Executor @@ -16,16 +17,21 @@ module Language.GraphQL.Executor , executeRequest ) where +import Control.Monad.Catch + ( Exception(..) + , MonadCatch(..) + , MonadThrow(..) + , SomeException(..) + ) import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Reader (ReaderT(..), local, runReader) +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 qualified Data.Aeson as Aeson import Data.Bifunctor (first) import Data.Foldable (find) import Data.Functor ((<&>)) -import Data.Functor.Identity (Identity) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) @@ -38,6 +44,7 @@ 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 @@ -48,15 +55,15 @@ import qualified Language.GraphQL.Type.Internal as Type.Internal import Language.GraphQL.Type.Schema (Schema, Type) import qualified Language.GraphQL.Type.Schema as Schema -data Replacement = Replacement +data Replacement m = Replacement { variableValues :: Type.Subs , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition , visitedFragments :: HashSet Full.Name - , types :: HashMap Full.Name (Type IO) + , types :: HashMap Full.Name (Type m) } newtype TransformT m a = TransformT - { runTransformT :: ReaderT Replacement m a + { runTransformT :: ReaderT (Replacement m) m a } instance Functor m => Functor (TransformT m) where @@ -72,7 +79,87 @@ instance Monad m => Monad (TransformT m) where instance MonadTrans TransformT where lift = TransformT . lift -type Transform = TransformT Identity +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 [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 + | EnumCompletionError + | InterfaceCompletionError + | UnionCompletionError + | ValueCompletionError + | ResultCoercionError + | NullResultError + +instance Show FieldError where + show ArgumentTypeError = "Invalid argument type." + show MissingArgumentError = "Required argument not specified." + show EnumCompletionError = "Enum value completion failed." + show InterfaceCompletionError = "Interface value completion failed." + show UnionCompletionError = "Union value completion failed." + show ValueCompletionError = "Value completion failed." + 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 Segment = Segment String | Index Int @@ -82,8 +169,8 @@ data Error = Error , path :: [Segment] } -data Response = Response - { data' :: Aeson.Object +data Response a = Response + { data' :: a , errors :: [Error] } @@ -93,7 +180,7 @@ data QueryError | CoercionError Full.VariableDefinition | UnknownInputType Full.VariableDefinition -asks :: forall a. (Replacement -> a) -> Transform a +asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a asks = TransformT . Reader.asks queryError :: QueryError -> Error @@ -125,49 +212,32 @@ queryError (UnknownInputType variableDefinition) = ] in Error{ message = queryErrorMessage, locations = [location], path = [] } -respondWithQueryError :: QueryError -> Response -respondWithQueryError = Response mempty . pure . queryError +data Operation m = Operation Full.OperationType (Seq (Selection m)) --- operationName selectionSet location -data Operation = Operation - Full.OperationType - Type.Subs - SelectionSet +data Selection m + = FieldSelection (Field m) + | FragmentSelection (Fragment m) -type SelectionSet = Seq Selection - -data Selection - = FieldSelection Field - | FragmentSelection Fragment - -data Argument = Argument Full.Name (Full.Node Input) Full.Location - -data Field = Field +data Field m = Field (Maybe Full.Name) Full.Name - [Argument] - SelectionSet + (HashMap Full.Name (Full.Node Input)) + (Seq (Selection m)) Full.Location -data Fragment = Fragment - (Type.Internal.CompositeType IO) SelectionSet Full.Location +data Fragment m = Fragment + (Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location data Input - = Variable Full.Name + = Variable Type.Value | Int Int32 | Float Double | String Text | Boolean Bool | Null | Enum Full.Name - | List [Full.Node Input] - | Object [ObjectField] - -data ObjectField = ObjectField - { name :: Full.Name - , value :: Full.Node Input - , location :: Full.Location - } + | List [Input] + | Object (HashMap Full.Name Input) document :: Full.Document -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition) @@ -181,26 +251,24 @@ document = foldr filterOperation ([], HashMap.empty) HashMap.insert fragmentName fragmentDefinition <$> accumulator filterOperation _ accumulator = accumulator -- Type system definitions. -transform :: Full.OperationDefinition -> Transform Operation +transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m) transform (Full.OperationDefinition operationType _ _ _ selectionSet' _) = do - coercedVariableValues <- asks variableValues transformedSelections <- selectionSet selectionSet' - pure $ Operation operationType coercedVariableValues transformedSelections + pure $ Operation operationType transformedSelections transform (Full.SelectionSet selectionSet' _) = do - coercedVariableValues <- asks variableValues transformedSelections <- selectionSet selectionSet' - pure $ Operation Full.Query coercedVariableValues transformedSelections + pure $ Operation Full.Query transformedSelections -selectionSet :: Full.SelectionSet -> Transform SelectionSet +selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m)) selectionSet = selectionSetOpt . NonEmpty.toList -selectionSetOpt :: Full.SelectionSetOpt -> Transform SelectionSet +selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m)) selectionSetOpt = foldM go Seq.empty where go accumulatedSelections currentSelection = selection currentSelection <&> (accumulatedSelections ><) -selection :: Full.Selection -> Transform SelectionSet +selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m)) selection (Full.FieldSelection field') = maybeToSelectionSet FieldSelection $ field field' selection (Full.FragmentSpreadSelection fragmentSpread') = @@ -208,17 +276,19 @@ selection (Full.FragmentSpreadSelection fragmentSpread') = selection (Full.InlineFragmentSelection inlineFragment') = either id (pure . FragmentSelection) <$> inlineFragment inlineFragment' -maybeToSelectionSet :: forall a - . (a -> Selection) - -> Transform (Maybe a) - -> Transform SelectionSet +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 :: [Full.Directive] -> Transform (Maybe [Type.Directive]) +directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive]) directives = fmap Type.selection . traverse directive -inlineFragment :: Full.InlineFragment - -> Transform (Either SelectionSet Fragment) +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' @@ -237,7 +307,7 @@ inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' loc then Left transformedSelections else Left Seq.empty -fragmentSpread :: Full.FragmentSpread -> Transform (Maybe Fragment) +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 @@ -263,10 +333,11 @@ fragmentSpread (Full.FragmentSpread spreadName directives' location) = do fragmentInserter replacement@Replacement{ visitedFragments } = replacement { visitedFragments = HashSet.insert spreadName visitedFragments } -field :: Full.Field -> Transform (Maybe Field) +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' @@ -274,24 +345,25 @@ field (Full.Field alias' name' arguments' directives' selectionSet' location') = 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 - transformedArguments = argument <$> arguments' + go accumulator (Full.Argument name' valueNode _) = do + argumentValue <- node valueNode + pure $ insertIfGiven name' argumentValue accumulator -argument :: Full.Argument -> Argument -argument (Full.Argument name' valueNode location') = - Argument name' (node valueNode) location' - -directive :: Full.Directive -> Transform Type.Directive -directive (Full.Directive name' arguments _) +directive :: Monad m => Full.Directive -> TransformT m Type.Directive +directive (Full.Directive name' arguments' _) = Type.Directive name' . Type.Arguments - <$> foldM go HashMap.empty 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 :: Full.Value -> Transform Type.Value +directiveValue :: Monad m => Full.Value -> TransformT m Type.Value directiveValue = \case (Full.Variable name') -> asks $ HashMap.lookupDefault Type.Null name' @@ -311,47 +383,58 @@ directiveValue = \case transformedValue <- directiveNode value pure $ HashMap.insert name transformedValue accumulator -variableValue :: Full.Value -> Input -variableValue (Full.Variable name') = Variable name' -variableValue (Full.Int integer) = Int integer -variableValue (Full.Float double) = Float double -variableValue (Full.String string) = String string -variableValue (Full.Boolean boolean) = Boolean boolean -variableValue Full.Null = Null -variableValue (Full.Enum enum) = Enum enum -variableValue (Full.List list) = List $ node <$> list -variableValue (Full.Object objectFields) = Object $ objectField <$> objectFields +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 :: Full.ObjectField Full.Value -> ObjectField - objectField Full.ObjectField{..} = ObjectField - { name = name - , value = node value - , location = location - } + objectField accumulator Full.ObjectField{..} = do + objectFieldValue <- fmap Full.node <$> node value + pure $ insertIfGiven name objectFieldValue accumulator -node :: Full.Node Full.Value -> Full.Node Input -node Full.Node{node = node', ..} = Full.Node (variableValue node') location +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 -executeRequest :: Schema IO +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 + +executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b) + => Schema m -> Full.Document -> Maybe String - -> Aeson.Object - -> Aeson.Object - -> IO Response -executeRequest schema sourceDocument operationName variableValues initialValue = + -> HashMap Full.Name b + -> m (Response a) +executeRequest schema sourceDocument operationName variableValues = do + operationAndVariables <- sequence buildOperation case operationAndVariables of - Left queryError' -> pure $ respondWithQueryError queryError' + Left queryError' -> pure + $ Response Coerce.null $ pure $ queryError queryError' Right operation - | Operation Full.Query coercedVariables topSelections <- operation -> - executeQuery topSelections schema coercedVariables initialValue - | Operation Full.Mutation corecedVariables topSelections <- operation -> - executeMutation topSelections schema corecedVariables initialValue - | Operation Full.Subscription coercedVariables topSelections <- operation -> - subscribe topSelections schema coercedVariables initialValue + | Operation Full.Query topSelections <- operation -> + executeQuery topSelections schema + | Operation Full.Mutation topSelections <- operation -> + executeMutation topSelections schema + | Operation Full.Subscription topSelections <- operation -> + subscribe topSelections schema where schemaTypes = Schema.types schema (operationDefinitions, fragmentDefinitions') = document sourceDocument - operationAndVariables = do + buildOperation = do operationDefinition <- getOperation operationDefinitions operationName coercedVariableValues <- coerceVariableValues schemaTypes @@ -363,8 +446,7 @@ executeRequest schema sourceDocument operationName variableValues initialValue = , visitedFragments = mempty , types = schemaTypes } - pure - $ flip runReader replacement + pure $ flip runReaderT replacement $ runTransformT $ transform operationDefinition @@ -379,77 +461,246 @@ getOperation operations (Just givenOperationName) findOperationByName _ = False getOperation _ _ = Left OperationNameRequired -executeQuery :: SelectionSet - -> Schema IO - -> Type.Subs - -> Aeson.Object - -> IO Response -executeQuery topSelections schema coercedVariables initialValue = +executeQuery :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) + -> Schema m + -> m (Response a) +executeQuery topSelections schema = do let queryType = Schema.query schema - _data = executeSelectionSet topSelections queryType initialValue coercedVariables - in pure $ Response mempty mempty + (data', errors) <- runWriterT + $ flip runReaderT (Schema.types schema) + $ runExecutorT + $ executeSelectionSet topSelections queryType Type.Null [] + pure $ Response data' errors -executeMutation :: forall m - . SelectionSet +executeMutation :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) -> Schema m - -> Type.Subs - -> Aeson.Object - -> IO Response -executeMutation _operation _schema _coercedVariableValues _initialValue = - pure $ Response mempty mempty + -> m (Response a) +executeMutation topSelections schema + | 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 + [Error "Schema doesn't define a mutation type." [] []] -subscribe :: forall m - . SelectionSet +-- TODO: Subscribe. +subscribe :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) -> Schema m - -> Type.Subs - -> Aeson.Object - -> IO Response -subscribe _operation _schema _coercedVariableValues _initialValue = - pure $ Response mempty mempty + -> m (Response a) +subscribe _operation _schema = + pure $ Response Coerce.null mempty -executeSelectionSet - :: SelectionSet - -> Out.ObjectType IO - -> Aeson.Object - -> Type.Subs - -> Aeson.Object -executeSelectionSet selections objectType objectValue variableValues = +executeSelectionSet :: (MonadCatch m, Coerce.Serialize a) + => Seq (Selection m) + -> Out.ObjectType m + -> Type.Value + -> [Segment] + -> ExecutorT m a +executeSelectionSet selections objectType objectValue errorPath = do let groupedFieldSet = collectFields objectType selections - in OrderedMap.foldlWithKey' go mempty groupedFieldSet + resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet + coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues where - Out.ObjectType _ _ _ resolvers = objectType executeField' fields resolver = - executeField objectType objectValue fields resolver variableValues - go resultMap responseKey fields@(Field _ fieldName _ _ _ :| _) = - case HashMap.lookup fieldName resolvers of - Just resolver -> - let responseValue = executeField' fields resolver - in HashMap.insert responseKey responseValue resultMap - Nothing -> resultMap + executeField objectValue fields resolver errorPath + Out.ObjectType _ _ _ resolvers = objectType + go fields@(Field _ fieldName _ _ _ :| _) = + traverse (executeField' fields) $ HashMap.lookup fieldName resolvers -executeField :: Out.ObjectType IO - -> Aeson.Object - -> NonEmpty Field - -> Out.Resolver IO - -> Type.Subs - -> Aeson.Value -executeField _objectType _objectValue fields fieldType _variableValues = - let _field'@(Field _ _fieldName inputArguments _ _) :| _ = fields - Out.Field _ _ argumentTypes = resolverField fieldType - _argumentValues = coerceArgumentValues argumentTypes inputArguments - in Aeson.Null +fieldsSegment :: forall m. NonEmpty (Field m) -> Segment +fieldsSegment (Field alias fieldName _ _ _ :| _) = + Segment (Text.unpack $ fromMaybe fieldName alias) + +executeField :: (MonadCatch m, Coerce.Serialize a) + => Type.Value + -> NonEmpty (Field m) + -> Out.Resolver m + -> [Segment] + -> ExecutorT m a +executeField objectValue fields resolver errorPath = + let Field _ fieldName inputArguments _ fieldLocation :| _ = fields + in catch (go fieldName inputArguments) $ exceptionHandler fieldLocation where - resolverField (Out.ValueResolver resolverField' _) = resolverField' - resolverField (Out.EventStreamResolver resolverField' _ _) = resolverField' + exceptionHandler :: (MonadCatch m, Coerce.Serialize a) + => Full.Location + -> GraphQLException + -> ExecutorT m a + exceptionHandler fieldLocation e = + let newError = Error (displayException e) [fieldLocation] errorPath + in ExecutorT (lift $ tell [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) -coerceArgumentValues :: HashMap Full.Name In.Argument - -> [Argument] - -> Either [Full.Location] Type.Subs -coerceArgumentValues _argumentDefinitions _argumentNodes = pure mempty +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 + } -collectFields :: Out.ObjectType IO - -> SelectionSet - -> OrderedMap (NonEmpty Field) +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) + -> [Segment] + -> 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 throwFieldError EnumCompletionError +completeValue (Out.ObjectBaseType objectType) fields errorPath result + = executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath +completeValue (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 -> throwFieldError InterfaceCompletionError +completeValue (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 -> throwFieldError UnionCompletionError +completeValue _ _ _ _ = throwFieldError ValueCompletionError + +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) + -> ExecutorT 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) = @@ -464,11 +715,10 @@ collectFields objectType = foldl forEach OrderedMap.empty in groupedFields <> fragmentGroupedFieldSet | otherwise = groupedFields -coerceVariableValues :: Coerce.VariableValue a - => forall m - . HashMap Full.Name (Schema.Type m) +coerceVariableValues :: (Monad m, Coerce.VariableValue b) + => HashMap Full.Name (Schema.Type m) -> Full.OperationDefinition - -> HashMap Full.Name a + -> HashMap Full.Name b -> Either QueryError Type.Subs coerceVariableValues types operationDefinition' variableValues | Full.OperationDefinition _ _ variableDefinitions _ _ _ <-