From b96d75f447ddfdea4a4788126f4b4d002672d858 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 3 Sep 2021 22:47:49 +0200 Subject: [PATCH] Replace the old executor --- graphql.cabal | 3 - src/Language/GraphQL/AST.hs | 4 +- src/Language/GraphQL/Error.hs | 4 + src/Language/GraphQL/Execute.hs | 613 +++++----------- src/Language/GraphQL/Execute/Execution.hs | 253 ------- src/Language/GraphQL/Execute/Subscribe.hs | 113 --- src/Language/GraphQL/Execute/Transform.hs | 604 +++++++-------- src/Language/GraphQL/Executor.hs | 847 ---------------------- src/Language/GraphQL/Type/Definition.hs | 1 + src/Language/GraphQL/Type/In.hs | 1 + tests/Language/GraphQL/ExecuteSpec.hs | 44 +- 11 files changed, 480 insertions(+), 2007 deletions(-) delete mode 100644 src/Language/GraphQL/Execute/Execution.hs delete mode 100644 src/Language/GraphQL/Execute/Subscribe.hs delete mode 100644 src/Language/GraphQL/Executor.hs diff --git a/graphql.cabal b/graphql.cabal index 8a49f22..9054347 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -47,11 +47,8 @@ library Language.GraphQL.Validate.Validation Test.Hspec.GraphQL other-modules: - Language.GraphQL.Execute.Execution Language.GraphQL.Execute.Internal - Language.GraphQL.Execute.Subscribe Language.GraphQL.Execute.Transform - Language.GraphQL.Executor Language.GraphQL.Type.Definition Language.GraphQL.Type.Internal Language.GraphQL.Validate.Rules diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index c7ceee8..4cf9bfd 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -1,6 +1,4 @@ -{- 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 Safe #-} -- | Target AST for parser. module Language.GraphQL.AST diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 2061c20..43be778 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.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 DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RecordWildCards #-} diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 8741ab5..8eb22c2 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -4,17 +4,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} module Language.GraphQL.Execute - ( Error(..) - , Operation(..) - , Path(..) - , Response(..) + ( module Language.GraphQL.Execute.Coerce , execute ) where @@ -29,32 +25,27 @@ import Control.Monad.Catch , catches ) 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.Trans.Reader (ReaderT(..), ask, runReaderT) +import Control.Monad.Trans.Writer (WriterT(..), runWriterT) +import qualified Control.Monad.Trans.Writer as Writer import Control.Monad (foldM) import qualified Language.GraphQL.AST.Document as Full -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 (intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe, isJust) -import Data.Sequence (Seq, (><)) +import Data.Maybe (fromMaybe) +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 GHC.Records (HasField(..)) -import qualified Language.GraphQL.Execute.Coerce as Coerce +import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.OrderedMap (OrderedMap) import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap +import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type as Type @@ -64,41 +55,11 @@ import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Error ( Error(..) , Response(..) - , Path(..) - , ResponseEventStream - ) -import Numeric (showFloat) - -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 + , Path(..) + , ResolverException(..) + , ResponseEventStream + ) +import Prelude hiding (null) newtype ExecutorT m a = ExecutorT { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a @@ -139,29 +100,31 @@ graphQLExceptionFromException e = do GraphQLException graphqlException <- fromException e cast graphqlException -data ResolverException = forall e. Exception e => ResolverException e +data ResultException = forall e. Exception e => ResultException e -instance Show ResolverException where - show (ResolverException e) = show e +instance Show ResultException where + show (ResultException e) = show e -instance Exception ResolverException where +instance Exception ResultException where toException = graphQLExceptionToException fromException = graphQLExceptionFromException -data FieldError - = ResultCoercionError - | NullResultError +resultExceptionToException :: Exception e => e -> SomeException +resultExceptionToException = toException . ResultException -instance Show FieldError where - show ResultCoercionError = "Result coercion failed." - show NullResultError = "Non-Nullable field resolver returned Null." +resultExceptionFromException :: Exception e => SomeException -> Maybe e +resultExceptionFromException e = do + ResultException resultException <- fromException e + cast resultException -newtype FieldException = FieldException FieldError - deriving Show +data FieldException = forall e. Exception e => FieldException Full.Location [Path] e + +instance Show FieldException where + show (FieldException _ _ e) = displayException e instance Exception FieldException where - toException = graphQLExceptionToException - fromException = graphQLExceptionFromException + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException data ValueCompletionException = ValueCompletionException String Type.Value @@ -175,11 +138,11 @@ instance Show ValueCompletionException where ] instance Exception ValueCompletionException where - toException = graphQLExceptionToException - fromException = graphQLExceptionFromException + toException = resultExceptionToException + fromException = resultExceptionFromException data InputCoercionException = - InputCoercionException String In.Type (Maybe (Full.Node Input)) + InputCoercionException String In.Type (Maybe (Full.Node Transform.Input)) instance Show InputCoercionException where show (InputCoercionException argumentName argumentType Nothing) = concat @@ -203,14 +166,27 @@ instance Exception InputCoercionException where toException = graphQLExceptionToException fromException = graphQLExceptionFromException -data QueryError - = OperationNameRequired - | OperationNotFound String - | CoercionError Full.VariableDefinition - | UnknownInputType Full.VariableDefinition +newtype ResultCoercionException = ResultCoercionException String -asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a -asks = TransformT . Reader.asks +instance Show ResultCoercionException where + show (ResultCoercionException typeRepresentation) = concat + [ "Unable to coerce result to " + , typeRepresentation + , "." + ] + +instance Exception ResultCoercionException where + toException = resultExceptionToException + fromException = resultExceptionFromException + +data QueryError + = OperationNameRequired + | OperationNotFound String + | CoercionError Full.VariableDefinition + | UnknownInputType Full.VariableDefinition + +tell :: Monad m => Seq Error -> ExecutorT m () +tell = ExecutorT . lift . Writer.tell queryError :: QueryError -> Error queryError OperationNameRequired = @@ -241,232 +217,7 @@ queryError (UnknownInputType variableDefinition) = ] 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) - deriving Eq - -instance Show Input where - showList = mappend . showList' - where - showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]" - show (Int integer) = show integer - show (Float float') = showFloat float' mempty - show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text - show (Boolean boolean') = show boolean' - show Null = "null" - show (Enum name) = Text.unpack name - show (List list) = show list - show (Object fields) = unwords - [ "{" - , intercalate ", " (HashMap.foldrWithKey showObject [] fields) - , "}" - ] - where - showObject key value accumulator = - concat [Text.unpack key, ": ", show value] : accumulator - show variableValue = show variableValue - -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 argumentLocation) = do - let replaceLocation = flip Full.Node argumentLocation . Full.node - argumentValue <- fmap replaceLocation <$> 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) +execute :: (MonadCatch m, VariableValue a, Serialize b) => Schema m -- ^ Resolvers. -> Maybe Text -- ^ Operation name. -> HashMap Full.Name a -- ^ Variable substitution function. @@ -475,7 +226,7 @@ execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b) execute schema' operationName subs document' = executeRequest schema' document' (Text.unpack <$> operationName) subs -executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b) +executeRequest :: (MonadCatch m, Serialize a, VariableValue b) => Schema m -> Full.Document -> Maybe String @@ -486,35 +237,36 @@ executeRequest schema sourceDocument operationName variableValues = do case operationAndVariables of Left queryError' -> pure $ Right - $ Response Coerce.null $ pure $ queryError queryError' + $ Response null $ pure $ queryError queryError' Right operation - | Operation Full.Query topSelections _operationLocation <- operation -> + | Transform.Operation Full.Query topSelections _operationLocation <- operation -> Right <$> executeQuery topSelections schema - | Operation Full.Mutation topSelections operationLocation <- operation -> + | Transform.Operation Full.Mutation topSelections operationLocation <- operation -> Right <$> executeMutation topSelections schema operationLocation - | Operation Full.Subscription topSelections operationLocation <- operation -> + | Transform.Operation Full.Subscription topSelections operationLocation <- operation -> either rightErrorResponse Left <$> subscribe topSelections schema operationLocation where schemaTypes = Schema.types schema - (operationDefinitions, fragmentDefinitions') = document sourceDocument + (operationDefinitions, fragmentDefinitions') = + Transform.document sourceDocument buildOperation = do operationDefinition <- getOperation operationDefinitions operationName coercedVariableValues <- coerceVariableValues schemaTypes operationDefinition variableValues - let replacement = Replacement + let replacement = Transform.Replacement { variableValues = coercedVariableValues , fragmentDefinitions = fragmentDefinitions' , visitedFragments = mempty , types = schemaTypes } pure $ flip runReaderT replacement - $ runTransformT - $ transform operationDefinition + $ Transform.runTransformT + $ Transform.transform operationDefinition -rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b) -rightErrorResponse = Right . Response Coerce.null . pure +rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b) +rightErrorResponse = Right . Response null . pure getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition getOperation [operation] Nothing = Right operation @@ -527,8 +279,8 @@ getOperation operations (Just givenOperationName) findOperationByName _ = False getOperation _ _ = Left OperationNameRequired -executeQuery :: (MonadCatch m, Coerce.Serialize a) - => Seq (Selection m) +executeQuery :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) -> Schema m -> m (Response a) executeQuery topSelections schema = do @@ -536,11 +288,26 @@ executeQuery topSelections schema = do (data', errors) <- runWriterT $ flip runReaderT (Schema.types schema) $ runExecutorT - $ executeSelectionSet topSelections queryType Type.Null [] + $ catch (executeSelectionSet topSelections queryType Type.Null []) + handleException pure $ Response data' errors -executeMutation :: (MonadCatch m, Coerce.Serialize a) - => Seq (Selection m) +handleException :: (MonadCatch m, Serialize a) + => FieldException + -> ExecutorT m a +handleException (FieldException fieldLocation errorPath next) = + let newError = constructError next fieldLocation errorPath + in tell (Seq.singleton newError) >> pure null + +constructError :: Exception e => e -> Full.Location -> [Path] -> Error +constructError e fieldLocation errorPath = Error + { message = Text.pack (displayException e) + , path = reverse errorPath + , locations = [fieldLocation] + } + +executeMutation :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) -> Schema m -> Full.Location -> m (Response a) @@ -549,15 +316,16 @@ executeMutation topSelections schema operationLocation (data', errors) <- runWriterT $ flip runReaderT (Schema.types schema) $ runExecutorT - $ executeSelectionSet topSelections mutationType Type.Null [] + $ catch (executeSelectionSet topSelections mutationType Type.Null []) + handleException pure $ Response data' errors | otherwise = pure - $ Response Coerce.null + $ Response null $ Seq.singleton $ Error "Schema doesn't support mutations." [operationLocation] [] -executeSelectionSet :: (MonadCatch m, Coerce.Serialize a) - => Seq (Selection m) +executeSelectionSet :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) -> Out.ObjectType m -> Type.Value -> [Path] @@ -565,62 +333,80 @@ executeSelectionSet :: (MonadCatch m, Coerce.Serialize a) executeSelectionSet selections objectType objectValue errorPath = do let groupedFieldSet = collectFields objectType selections resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet - coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues + coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues where executeField' fields resolver = executeField objectValue fields resolver errorPath Out.ObjectType _ _ _ resolvers = objectType - go fields@(Field _ fieldName _ _ _ :| _) = + go fields@(Transform.Field _ fieldName _ _ _ :| _) = traverse (executeField' fields) $ HashMap.lookup fieldName resolvers -fieldsSegment :: forall m. NonEmpty (Field m) -> Path -fieldsSegment (Field alias fieldName _ _ _ :| _) = +fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path +fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) = Segment (fromMaybe fieldName alias) -executeField :: (MonadCatch m, Coerce.Serialize a) +viewResolver :: Out.Resolver m -> (Out.Field m, Out.Resolve m) +viewResolver (Out.ValueResolver resolverField' resolveFunction) = + (resolverField', resolveFunction) +viewResolver (Out.EventStreamResolver resolverField' resolveFunction _) = + (resolverField', resolveFunction) + +executeField :: forall m a + . (MonadCatch m, Serialize a) => Type.Value - -> NonEmpty (Field m) + -> NonEmpty (Transform.Field m) -> Out.Resolver m -> [Path] -> ExecutorT m a -executeField objectValue fields resolver errorPath = - let Field _ fieldName inputArguments _ fieldLocation :| _ = fields +executeField objectValue fields (viewResolver -> resolverPair) errorPath = + let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields in catches (go fieldName inputArguments) - [ Handler (inputCoercionHandler fieldLocation) - , Handler (graphqlExceptionHandler fieldLocation) + [ Handler nullResultHandler + , Handler (inputCoercionHandler fieldLocation) + , Handler (resultHandler fieldLocation) + , Handler (resolverHandler fieldLocation) ] where - inputCoercionHandler :: (MonadCatch m, Coerce.Serialize a) + inputCoercionHandler :: (MonadCatch m, Serialize a) => Full.Location -> InputCoercionException -> ExecutorT m a inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = let argumentLocation = getField @"location" valueNode - in exceptionHandler argumentLocation $ displayException e - inputCoercionHandler fieldLocation e = - exceptionHandler fieldLocation $ displayException e - graphqlExceptionHandler :: (MonadCatch m, Coerce.Serialize a) + in exceptionHandler argumentLocation e + inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e + resultHandler :: (MonadCatch m, Serialize a) => Full.Location - -> GraphQLException + -> ResultException -> ExecutorT m a - graphqlExceptionHandler fieldLocation e = - exceptionHandler fieldLocation $ displayException e - exceptionHandler errorLocation exceptionText = - let newError = Error (Text.pack exceptionText) [errorLocation] - $ reverse - $ fieldsSegment fields : errorPath - in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null + resultHandler = exceptionHandler + resolverHandler :: (MonadCatch m, Serialize a) + => Full.Location + -> ResolverException + -> ExecutorT m a + resolverHandler = exceptionHandler + nullResultHandler :: (MonadCatch m, Serialize a) + => FieldException + -> ExecutorT m a + nullResultHandler e@(FieldException fieldLocation errorPath' next) = + let newError = constructError next fieldLocation errorPath' + in if Out.isNonNullType fieldType + then throwM e + else returnError newError + exceptionHandler errorLocation e = + let newPath = fieldsSegment fields : errorPath + newError = constructError e errorLocation newPath + in if Out.isNonNullType fieldType + then throwM $ FieldException errorLocation newPath e + else returnError newError + returnError newError = tell (Seq.singleton newError) >> pure null go fieldName inputArguments = do - let (Out.Field _ fieldType argumentTypes, resolveFunction) = - resolverField resolver argumentValues <- coerceArgumentValues argumentTypes inputArguments resolvedValue <- - resolveFieldValue resolveFunction objectValue fieldName argumentValues + resolveFieldValue resolveFunction objectValue fieldName argumentValues completeValue fieldType fields errorPath resolvedValue - resolverField (Out.ValueResolver resolverField' resolveFunction) = - (resolverField', resolveFunction) - resolverField (Out.EventStreamResolver resolverField' resolveFunction _) = - (resolverField', resolveFunction) + (resolverField, resolveFunction) = resolverPair + Out.Field _ fieldType argumentTypes = resolverField resolveFieldValue :: MonadCatch m => Out.Resolve m @@ -651,34 +437,33 @@ resolveAbstractType abstractType values' _ -> pure Nothing | otherwise = pure Nothing -completeValue :: (MonadCatch m, Coerce.Serialize a) +completeValue :: (MonadCatch m, Serialize a) => Out.Type m - -> NonEmpty (Field m) + -> NonEmpty (Transform.Field m) -> [Path] -> Type.Value -> ExecutorT m a -completeValue outputType _ _ Type.Null - | Out.isNonNullType outputType = throwFieldError NullResultError - | otherwise = pure Coerce.null +completeValue (Out.isNonNullType -> False) _ _ Type.Null = + pure null completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list) - = foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd + = foldM go (0, []) list >>= coerceResult outputType . 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 + coerceResult outputType $ Int int completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) = - coerceResult outputType $ Coerce.Boolean boolean + coerceResult outputType $ Boolean boolean completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) = - coerceResult outputType $ Coerce.Float float + coerceResult outputType $ Float float completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) = - coerceResult outputType $ Coerce.String string + coerceResult outputType $ 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 + then coerceResult outputType $ Enum enum else throwM $ ValueCompletionException (show outputType) $ Type.Enum enum @@ -708,28 +493,25 @@ completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result completeValue outputType _ _ result = throwM $ ValueCompletionException (show outputType) result -coerceResult :: (MonadCatch m, Coerce.Serialize a) +coerceResult :: (MonadCatch m, Serialize a) => Out.Type m - -> Coerce.Output a + -> Output a -> ExecutorT m a coerceResult outputType result - | Just serialized <- Coerce.serialize outputType result = pure serialized - | otherwise = throwFieldError ResultCoercionError + | Just serialized <- serialize outputType result = pure serialized + | otherwise = throwM $ ResultCoercionException $ show outputType mergeSelectionSets :: MonadCatch m - => NonEmpty (Field m) - -> Seq (Selection m) + => NonEmpty (Transform.Field m) + -> Seq (Transform.Selection m) mergeSelectionSets = foldr forEach mempty where - forEach (Field _ _ _ fieldSelectionSet _) selectionSet' = + forEach (Transform.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) + -> HashMap Full.Name (Full.Node Transform.Input) -> m Type.Subs coerceArgumentValues argumentDefinitions argumentValues = HashMap.foldrWithKey c pure argumentDefinitions mempty @@ -754,53 +536,53 @@ coerceArgumentValues argumentDefinitions argumentValues = $ Just inputValue | otherwise -> throwM $ InputCoercionException (Text.unpack argumentName) variableType Nothing - matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue + matchFieldValues' = 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 + coerceArgumentValue inputType (Transform.Int integer) = + coerceInputLiteral inputType (Type.Int integer) + coerceArgumentValue inputType (Transform.Boolean boolean) = + coerceInputLiteral inputType (Type.Boolean boolean) + coerceArgumentValue inputType (Transform.String string) = + coerceInputLiteral inputType (Type.String string) + coerceArgumentValue inputType (Transform.Float float) = + coerceInputLiteral inputType (Type.Float float) + coerceArgumentValue inputType (Transform.Enum enum) = + coerceInputLiteral inputType (Type.Enum enum) + coerceArgumentValue inputType Transform.Null | In.isNonNullType inputType = Nothing - | otherwise = Coerce.coerceInputLiteral inputType Type.Null - coerceArgumentValue (In.ListBaseType inputType) (List list) = + | otherwise = coerceInputLiteral inputType Type.Null + coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = let coerceItem = coerceArgumentValue inputType in Type.List <$> traverse coerceItem list - coerceArgumentValue (In.InputObjectBaseType inputType) (Object object) + coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.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 _ (Transform.Variable variable) = pure variable coerceArgumentValue _ _ = Nothing forEachField object variableName (In.InputField _ variableType defaultValue) = - Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue + matchFieldValues coerceArgumentValue object variableName variableType defaultValue collectFields :: Monad m => Out.ObjectType m - -> Seq (Selection m) - -> OrderedMap (NonEmpty (Field m)) + -> Seq (Transform.Selection m) + -> OrderedMap (NonEmpty (Transform.Field m)) collectFields objectType = foldl forEach OrderedMap.empty where - forEach groupedFields (FieldSelection fieldSelection) = - let Field maybeAlias fieldName _ _ _ = fieldSelection + forEach groupedFields (Transform.FieldSelection fieldSelection) = + let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection responseKey = fromMaybe fieldName maybeAlias in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields - forEach groupedFields (FragmentSelection selectionFragment) - | Fragment fragmentType fragmentSelectionSet _ <- selectionFragment + forEach groupedFields (Transform.FragmentSelection selectionFragment) + | Transform.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) +coerceVariableValues :: (Monad m, VariableValue b) => HashMap Full.Name (Schema.Type m) -> Full.OperationDefinition -> HashMap Full.Name b @@ -818,7 +600,7 @@ coerceVariableValues types operationDefinition' variableValues in case Type.Internal.lookupInputType variableTypeName types of Just variableType -> maybe (Left $ CoercionError variableDefinition) Right - $ Coerce.matchFieldValues + $ matchFieldValues coerceVariableValue' variableValues variableName @@ -828,8 +610,8 @@ coerceVariableValues types operationDefinition' variableValues Nothing -> Left $ UnknownInputType variableDefinition forEach _ coercedValuesOrError = coercedValuesOrError coerceVariableValue' variableType value' - = Coerce.coerceVariableValue variableType value' - >>= Coerce.coerceInputLiteral variableType + = coerceVariableValue variableType value' + >>= coerceInputLiteral variableType constValue :: Full.ConstValue -> Type.Value constValue (Full.ConstInt i) = Type.Int i @@ -845,8 +627,8 @@ constValue (Full.ConstObject o) = constObjectField Full.ObjectField{value = value', ..} = (name, constValue $ Full.node value') -subscribe :: (MonadCatch m, Coerce.Serialize a) - => Seq (Selection m) +subscribe :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) -> Schema m -> Full.Location -> m (Either Error (ResponseEventStream m a)) @@ -861,10 +643,10 @@ subscribe fields schema objectLocation | otherwise = pure $ Left $ Error "Schema doesn't support subscriptions." [] [] -mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a) +mapSourceToResponseEvent :: (MonadCatch m, Serialize a) => HashMap Full.Name (Type m) -> Out.ObjectType m - -> Seq (Selection m) + -> Seq (Transform.Selection m) -> Out.SourceEventStream m -> m (ResponseEventStream m a) mapSourceToResponseEvent types' subscriptionType fields sourceStream @@ -876,11 +658,12 @@ createSourceEventStream :: MonadCatch m => HashMap Full.Name (Type m) -> Out.ObjectType m -> Full.Location - -> Seq (Selection m) + -> Seq (Transform.Selection m) -> m (Either Error (Out.SourceEventStream m)) createSourceEventStream _types subscriptionType objectLocation fields | [fieldGroup] <- OrderedMap.elems groupedFieldSet - , Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup + , Transform.Field _ fieldName arguments' _ errorLocation <- + NonEmpty.head fieldGroup , Out.ObjectType _ _ _ fieldTypes <- subscriptionType , resolverT <- fieldTypes HashMap.! fieldName , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT @@ -889,16 +672,15 @@ createSourceEventStream _types subscriptionType objectLocation fields Left _ -> pure $ Left $ Error "Argument coercion failed." [errorLocation] [] - Right argumentValues -> left (singleError' [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 - -singleError' :: [Full.Location] -> String -> Error -singleError' errorLocations message = Error (Text.pack message) errorLocations [] + singleError :: [Full.Location] -> String -> Error + singleError errorLocations message = Error (Text.pack message) errorLocations [] resolveFieldEventStream :: MonadCatch m => Type.Value @@ -917,15 +699,16 @@ resolveFieldEventStream result args resolver = , Type.values = result } -executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a) +executeSubscriptionEvent :: (MonadCatch m, Serialize a) => HashMap Full.Name (Type m) -> Out.ObjectType m - -> Seq (Selection m) + -> Seq (Transform.Selection m) -> Type.Value -> m (Response a) executeSubscriptionEvent types' objectType fields initialValue = do (data', errors) <- runWriterT $ flip runReaderT types' $ runExecutorT - $ executeSelectionSet fields objectType initialValue [] + $ catch (executeSelectionSet fields objectType initialValue []) + handleException pure $ Response data' errors diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs deleted file mode 100644 index 9ad4439..0000000 --- a/src/Language/GraphQL/Execute/Execution.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Language.GraphQL.Execute.Execution - ( coerceArgumentValues - , collectFields - , executeSelectionSet - ) where - -import Control.Monad.Catch (Exception(..), MonadCatch(..)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.Trans.State (gets) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (fromMaybe) -import Data.Sequence (Seq(..)) -import qualified Data.Text as Text -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.Error -import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Internal -import Language.GraphQL.Execute.OrderedMap (OrderedMap) -import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap -import qualified Language.GraphQL.Execute.Transform as Transform -import qualified Language.GraphQL.Type as Type -import qualified Language.GraphQL.Type.In as In -import qualified Language.GraphQL.Type.Out as Out -import qualified Language.GraphQL.Type.Internal as Internal -import Prelude hiding (null) - -resolveFieldValue :: MonadCatch m - => Type.Value - -> Type.Subs - -> Type.Resolve m - -> Full.Location - -> CollectErrsT m Type.Value -resolveFieldValue result args resolver location' = - catch (lift $ runReaderT resolver context) handleFieldError - where - handleFieldError :: MonadCatch m - => ResolverException - -> CollectErrsT m Type.Value - handleFieldError e - = addError Type.Null - $ Error (Text.pack $ displayException e) [location'] [] - context = Type.Context - { Type.arguments = Type.Arguments args - , Type.values = result - } - -collectFields :: Monad m - => Out.ObjectType m - -> Seq (Transform.Selection m) - -> OrderedMap (NonEmpty (Transform.Field m)) -collectFields objectType = foldl forEach OrderedMap.empty - where - forEach groupedFields (Transform.SelectionField field) = - let responseKey = aliasOrName field - in OrderedMap.insert responseKey (field :| []) groupedFields - forEach groupedFields (Transform.SelectionFragment selectionFragment) - | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment - , Internal.doesFragmentTypeApply fragmentType objectType = - let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet - in groupedFields <> fragmentGroupedFieldSet - | otherwise = groupedFields - -aliasOrName :: forall m. Transform.Field m -> Full.Name -aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias - -resolveAbstractType :: Monad m - => Internal.AbstractType m - -> Type.Subs - -> CollectErrsT m (Maybe (Out.ObjectType m)) -resolveAbstractType abstractType values' - | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do - types' <- gets types - case HashMap.lookup typeName types' of - Just (Internal.ObjectType objectType) -> - if Internal.instanceOf objectType abstractType - then pure $ Just objectType - else pure Nothing - _ -> pure Nothing - | otherwise = pure Nothing - -executeField :: (MonadCatch m, Serialize a) - => Out.Resolver m - -> Type.Value - -> NonEmpty (Transform.Field m) - -> CollectErrsT m a -executeField fieldResolver prev fields - | Out.ValueResolver fieldDefinition resolver <- fieldResolver = - executeField' fieldDefinition resolver - | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver = - executeField' fieldDefinition resolver - where - executeField' fieldDefinition resolver = do - let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields - case coerceArgumentValues argumentDefinitions arguments' of - Left [] -> - let errorMessage = "Not all required arguments are specified." - in addError null $ Error errorMessage [location'] [] - Left errorLocations -> addError null - $ Error "Argument coercing failed." errorLocations [] - Right argumentValues -> do - answer <- resolveFieldValue prev argumentValues resolver location' - completeValue fieldType fields answer - -completeValue :: (MonadCatch m, Serialize a) - => Out.Type m - -> NonEmpty (Transform.Field m) - -> Type.Value - -> CollectErrsT m a -completeValue (Out.isNonNullType -> False) _ Type.Null = pure null -completeValue outputType@(Out.ListBaseType listType) fields (Type.List list) - = traverse (completeValue listType fields) list - >>= coerceResult outputType (firstFieldLocation fields) . List -completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) = - coerceResult outputType (firstFieldLocation fields) $ Int int -completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) = - coerceResult outputType (firstFieldLocation fields) $ Boolean boolean -completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) = - coerceResult outputType (firstFieldLocation fields) $ Float float -completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) = - coerceResult outputType (firstFieldLocation fields) $ String string -completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) = - let Type.EnumType _ _ enumMembers = enumType - location = firstFieldLocation fields - in if HashMap.member enum enumMembers - then coerceResult outputType location $ Enum enum - else addError null $ Error "Enum value completion failed." [location] [] -completeValue (Out.ObjectBaseType objectType) fields result - = executeSelectionSet result objectType (firstFieldLocation fields) - $ mergeSelectionSets fields -completeValue (Out.InterfaceBaseType interfaceType) fields result - | Type.Object objectMap <- result = do - let abstractType = Internal.AbstractInterfaceType interfaceType - let location = firstFieldLocation fields - concreteType <- resolveAbstractType abstractType objectMap - case concreteType of - Just objectType -> executeSelectionSet result objectType location - $ mergeSelectionSets fields - Nothing -> addError null - $ Error "Interface value completion failed." [location] [] -completeValue (Out.UnionBaseType unionType) fields result - | Type.Object objectMap <- result = do - let abstractType = Internal.AbstractUnionType unionType - let location = firstFieldLocation fields - concreteType <- resolveAbstractType abstractType objectMap - case concreteType of - Just objectType -> executeSelectionSet result objectType - location $ mergeSelectionSets fields - Nothing -> addError null - $ Error "Union value completion failed." [location] [] -completeValue _ (Transform.Field _ _ _ _ location :| _) _ = - addError null $ Error "Value completion failed." [location] [] - -mergeSelectionSets :: MonadCatch m - => NonEmpty (Transform.Field m) - -> Seq (Transform.Selection m) -mergeSelectionSets = foldr forEach mempty - where - forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet = - selectionSet <> fieldSelectionSet - -firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location -firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation - -coerceResult :: (MonadCatch m, Serialize a) - => Out.Type m - -> Full.Location - -> Output a - -> CollectErrsT m a -coerceResult outputType parentLocation result - | Just serialized <- serialize outputType result = pure serialized - | otherwise = addError null - $ Error "Result coercion failed." [parentLocation] [] - --- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies --- each field to each 'Transform.Selection'. Resolves into a value containing --- the resolved 'Transform.Selection', or a null value and error information. -executeSelectionSet :: (MonadCatch m, Serialize a) - => Type.Value - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> CollectErrsT m a -executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do - let fields = collectFields objectType selectionSet - resolvedValues <- OrderedMap.traverseMaybe forEach fields - coerceResult (Out.NonNullObjectType objectType) objectLocation - $ Object resolvedValues - where - forEach fields@(field :| _) = - let Transform.Field _ name _ _ _ = field - in traverse (tryResolver fields) $ lookupResolver name - lookupResolver = flip HashMap.lookup resolvers - tryResolver fields resolver = - executeField resolver result fields >>= lift . pure - -coerceArgumentValues - :: HashMap Full.Name In.Argument - -> HashMap Full.Name (Full.Node Transform.Input) - -> Either [Full.Location] Type.Subs -coerceArgumentValues argumentDefinitions argumentNodes = - HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions - where - forEach argumentName (In.Argument _ variableType defaultValue) = \case - Right resultMap - | Just matchedValues - <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap - -> Right matchedValues - | otherwise -> Left $ generateError argumentName [] - Left errorLocations - | Just _ - <- matchFieldValues' argumentName variableType defaultValue $ pure mempty - -> Left errorLocations - | otherwise -> Left $ generateError argumentName errorLocations - generateError argumentName errorLocations = - case HashMap.lookup argumentName argumentNodes of - Just (Full.Node _ errorLocation) -> [errorLocation] - Nothing -> errorLocations - matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes) - coerceArgumentValue inputType (Transform.Int integer) = - coerceInputLiteral inputType (Type.Int integer) - coerceArgumentValue inputType (Transform.Boolean boolean) = - coerceInputLiteral inputType (Type.Boolean boolean) - coerceArgumentValue inputType (Transform.String string) = - coerceInputLiteral inputType (Type.String string) - coerceArgumentValue inputType (Transform.Float float) = - coerceInputLiteral inputType (Type.Float float) - coerceArgumentValue inputType (Transform.Enum enum) = - coerceInputLiteral inputType (Type.Enum enum) - coerceArgumentValue inputType Transform.Null - | In.isNonNullType inputType = Nothing - | otherwise = coerceInputLiteral inputType Type.Null - coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = - let coerceItem = coerceInputLiteral inputType - in Type.List <$> traverse coerceItem list - coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) - | In.InputObjectType _ _ inputFields <- inputType = - let go = forEachField object - resultMap = HashMap.foldrWithKey go (pure mempty) inputFields - in Type.Object <$> resultMap - coerceArgumentValue _ (Transform.Variable variable) = pure variable - coerceArgumentValue _ _ = Nothing - forEachField object variableName (In.InputField _ variableType defaultValue) = - matchFieldValues coerceArgumentValue object variableName variableType defaultValue diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs deleted file mode 100644 index 5d8d294..0000000 --- a/src/Language/GraphQL/Execute/Subscribe.hs +++ /dev/null @@ -1,113 +0,0 @@ -{- 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.Arrow (left) -import Control.Monad.Catch (Exception(..), MonadCatch(..)) -import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List.NonEmpty as NonEmpty -import Data.Sequence (Seq(..)) -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Execution -import Language.GraphQL.Execute.Internal -import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap -import qualified Language.GraphQL.Execute.Transform as Transform -import Language.GraphQL.Error - ( Error(..) - , ResolverException - , Response - , ResponseEventStream - , runCollectErrs - ) -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 - -subscribe :: (MonadCatch m, Serialize a) - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> m (Either Error (ResponseEventStream m a)) -subscribe types' objectType objectLocation fields = do - sourceStream <- - createSourceEventStream types' objectType objectLocation fields - let traverser = - mapSourceToResponseEvent types' objectType objectLocation fields - traverse traverser sourceStream - -mapSourceToResponseEvent :: (MonadCatch m, Serialize a) - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> Out.SourceEventStream m - -> m (ResponseEventStream m a) -mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream - = pure - $ sourceStream - .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields) - -createSourceEventStream :: MonadCatch m - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> m (Either Error (Out.SourceEventStream m)) -createSourceEventStream _types subscriptionType objectLocation fields - | [fieldGroup] <- OrderedMap.elems groupedFieldSet - , Transform.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 - -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, Serialize a) - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> Definition.Value - -> m (Response a) -executeSubscriptionEvent types' objectType objectLocation fields initialValue - = runCollectErrs types' - $ executeSelectionSet initialValue objectType objectLocation fields diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 117b708..b2bd643 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -6,7 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} -- | After the document is parsed, before getting executed, the AST is -- transformed into a similar, simpler AST. Performed transformations include: @@ -21,65 +21,84 @@ -- This module is also responsible for smaller rewrites that touch only parts of -- the original AST. module Language.GraphQL.Execute.Transform - ( Document(..) - , Field(..) + ( Field(..) , Fragment(..) , Input(..) , Operation(..) - , QueryError(..) + , Replacement(..) , Selection(..) + , TransformT(..) , document + , transform ) where -import Control.Monad (foldM, unless) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (State, evalStateT, gets, modify) -import Data.Foldable (find) -import Data.Functor.Identity (Identity(..)) +import Control.Monad (foldM) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (ReaderT(..), local) +import qualified Control.Monad.Trans.Reader as Reader +import Data.Bifunctor (first) +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.Maybe (fromMaybe) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (intercalate) import qualified Data.List.NonEmpty as NonEmpty -import Data.Sequence (Seq, (<|), (><)) +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 qualified Language.GraphQL.AST as Full -import Language.GraphQL.AST (Name) -import qualified Language.GraphQL.Execute.Coerce as Coerce -import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.AST.Document as Full +import Language.GraphQL.Type.Schema (Type) import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Internal as Type -import qualified Language.GraphQL.Type.Out as Out -import qualified Language.GraphQL.Type.Schema as Schema +import Numeric (showFloat) --- | Associates a fragment name with a list of 'Field's. data Replacement m = Replacement - { fragments :: HashMap Full.Name (Fragment m) - , fragmentDefinitions :: FragmentDefinitions - , variableValues :: Type.Subs - , types :: HashMap Full.Name (Schema.Type m) + { variableValues :: Type.Subs + , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition + , visitedFragments :: HashSet Full.Name + , types :: HashMap Full.Name (Type m) } -type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition +newtype TransformT m a = TransformT + { runTransformT :: ReaderT (Replacement m) m a + } --- | Represents fragments and inline fragments. -data Fragment m - = Fragment (Type.CompositeType m) (Seq (Selection m)) +instance Functor m => Functor (TransformT m) where + fmap f = TransformT . fmap f . runTransformT --- | Single selection element. -data Selection m - = SelectionFragment (Fragment m) - | SelectionField (Field m) +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 + +asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a +asks = TransformT . Reader.asks --- | GraphQL has 3 operation types: queries, mutations and subscribtions. data Operation m - = Query (Maybe Text) (Seq (Selection m)) Full.Location - | Mutation (Maybe Text) (Seq (Selection m)) Full.Location - | Subscription (Maybe Text) (Seq (Selection m)) Full.Location + = Operation Full.OperationType (Seq (Selection m)) Full.Location + +data Selection m + = FieldSelection (Field m) + | FragmentSelection (Fragment m) --- | Single GraphQL field. data Field m = Field (Maybe Full.Name) Full.Name @@ -87,339 +106,214 @@ data Field m = Field (Seq (Selection m)) Full.Location --- | Contains the operation to be executed along with its root type. -data Document m = Document - (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m) - -data OperationDefinition = OperationDefinition - Full.OperationType - (Maybe Full.Name) - [Full.VariableDefinition] - [Full.Directive] - Full.SelectionSet - Full.Location - --- | Query error types. -data QueryError - = OperationNotFound Text - | OperationNameRequired - | CoercionError - | EmptyDocument - | UnsupportedRootOperation - -instance Show QueryError where - show (OperationNotFound operationName) = unwords - ["Operation", Text.unpack operationName, "couldn't be found in the document."] - show OperationNameRequired = "Missing operation name." - show CoercionError = "Coercion error." - show EmptyDocument = - "The document doesn't contain any executable operations." - show UnsupportedRootOperation = - "Root operation type couldn't be found in the schema." +data Fragment m = Fragment + (Type.CompositeType m) (Seq (Selection m)) Full.Location data Input - = Int Int32 + = Variable Type.Value + | Int Int32 | Float Double | String Text | Boolean Bool | Null - | Enum Name - | List [Type.Value] - | Object (HashMap Name Input) - | Variable Type.Value - deriving (Eq, Show) + | Enum Full.Name + | List [Input] + | Object (HashMap Full.Name Input) + deriving Eq -getOperation - :: Maybe Full.Name - -> NonEmpty OperationDefinition - -> Either QueryError OperationDefinition -getOperation Nothing (operation' :| []) = pure operation' -getOperation Nothing _ = Left OperationNameRequired -getOperation (Just operationName) operations - | Just operation' <- find matchingName operations = pure operation' - | otherwise = Left $ OperationNotFound operationName +instance Show Input where + showList = mappend . showList' + where + showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]" + show (Int integer) = show integer + show (Float float') = showFloat float' mempty + show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text + show (Boolean boolean') = show boolean' + show Null = "null" + show (Enum name) = Text.unpack name + show (List list) = show list + show (Object fields) = unwords + [ "{" + , intercalate ", " (HashMap.foldrWithKey showObject [] fields) + , "}" + ] + where + showObject key value accumulator = + concat [Text.unpack key, ": ", show value] : accumulator + show variableValue = show variableValue + +document :: Full.Document + -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition) +document = foldr filterOperation ([], HashMap.empty) where - matchingName (OperationDefinition _ name _ _ _ _) = - name == Just operationName + 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. -coerceVariableValues :: Coerce.VariableValue a - => forall m - . HashMap Full.Name (Schema.Type m) - -> OperationDefinition - -> HashMap.HashMap Full.Name a - -> Either QueryError Type.Subs -coerceVariableValues types operationDefinition variableValues = - let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition - in maybe (Left CoercionError) Right - $ foldr forEach (Just HashMap.empty) variableDefinitions +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 - forEach variableDefinition coercedValues = do - let Full.VariableDefinition variableName variableTypeName defaultValue _ = - variableDefinition - let defaultValue' = constValue . Full.node <$> defaultValue - variableType <- Type.lookupInputType variableTypeName types + go accumulatedSelections currentSelection = + selection currentSelection <&> (accumulatedSelections ><) - Coerce.matchFieldValues - coerceVariableValue' - variableValues - variableName - variableType - defaultValue' - coercedValues - coerceVariableValue' variableType value' - = Coerce.coerceVariableValue variableType value' - >>= Coerce.coerceInputLiteral variableType +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' -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 +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 [Definition.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.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.lookupTypeCondition typeCondition + . types + traverse (traverseSelections selections) fragmentType + Nothing -> pure Nothing where - constObjectField Full.ObjectField{value = value', ..} = - (name, constValue $ Full.node value') + 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 } --- | Rewrites the original syntax tree into an intermediate representation used --- for query execution. -document :: Coerce.VariableValue a - => forall m - . Type.Schema m - -> Maybe Full.Name +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 argumentLocation) = do + let replaceLocation = flip Full.Node argumentLocation . Full.node + argumentValue <- fmap replaceLocation <$> node valueNode + pure $ insertIfGiven name' argumentValue accumulator + +directive :: Monad m => Full.Directive -> TransformT m Definition.Directive +directive (Full.Directive name' arguments' _) + = Definition.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 - -> Full.Document - -> Either QueryError (Document m) -document schema operationName subs ast = do - let referencedTypes = Schema.types schema + -> HashMap Full.Name a +insertIfGiven name (Just v) = HashMap.insert name v +insertIfGiven _ _ = id - (operations, fragmentTable) <- defragment ast - chosenOperation <- getOperation operationName operations - coercedValues <- coerceVariableValues referencedTypes chosenOperation subs +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 - let replacement = Replacement - { fragments = HashMap.empty - , fragmentDefinitions = fragmentTable - , variableValues = coercedValues - , types = referencedTypes - } - case chosenOperation of - OperationDefinition Full.Query _ _ _ _ _ -> - pure $ Document referencedTypes (Schema.query schema) - $ operation chosenOperation replacement - OperationDefinition Full.Mutation _ _ _ _ _ - | Just mutationType <- Schema.mutation schema -> - pure $ Document referencedTypes mutationType - $ operation chosenOperation replacement - OperationDefinition Full.Subscription _ _ _ _ _ - | Just subscriptionType <- Schema.subscription schema -> - pure $ Document referencedTypes subscriptionType - $ operation chosenOperation replacement - _ -> Left UnsupportedRootOperation - -defragment - :: Full.Document - -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions) -defragment ast = - let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast - nonEmptyOperations = NonEmpty.nonEmpty operations - emptyDocument = Left EmptyDocument - in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations - where - defragment' definition (operations, fragments') - | (Full.ExecutableDefinition executable) <- definition - , (Full.DefinitionOperation operation') <- executable = - (transform operation' : operations, fragments') - | (Full.ExecutableDefinition executable) <- definition - , (Full.DefinitionFragment fragment) <- executable - , (Full.FragmentDefinition name _ _ _ _) <- fragment = - (operations, HashMap.insert name fragment fragments') - defragment' _ acc = acc - transform = \case - Full.OperationDefinition type' name variables directives' selections location -> - OperationDefinition type' name variables directives' selections location - Full.SelectionSet selectionSet location -> - OperationDefinition Full.Query Nothing mempty mempty selectionSet location - --- * Operation - -operation :: OperationDefinition -> Replacement m -> Operation m -operation operationDefinition replacement - = runIdentity - $ evalStateT (collectFragments >> transform operationDefinition) replacement - where - transform (OperationDefinition Full.Query name _ _ sels location) = - flip (Query name) location <$> appendSelection sels - transform (OperationDefinition Full.Mutation name _ _ sels location) = - flip (Mutation name) location <$> appendSelection sels - transform (OperationDefinition Full.Subscription name _ _ sels location) = - flip (Subscription name) location <$> appendSelection sels - --- * Selection - -selection - :: Full.Selection - -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) -selection (Full.FieldSelection fieldSelection) = - maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection -selection (Full.FragmentSpreadSelection fragmentSelection) - = maybe (Left mempty) (Right . SelectionFragment) - <$> fragmentSpread fragmentSelection -selection (Full.InlineFragmentSelection fragmentSelection) = - inlineFragment fragmentSelection - -field :: Full.Field -> State (Replacement m) (Maybe (Field m)) -field (Full.Field alias name arguments' directives' selections location) = do - fieldArguments <- foldM go HashMap.empty arguments' - fieldSelections <- appendSelection selections - fieldDirectives <- Definition.selection <$> directives directives' - let field' = Field alias name fieldArguments fieldSelections location - pure $ field' <$ fieldDirectives - where - go arguments (Full.Argument name' (Full.Node value' _) location') = do - objectFieldValue <- input value' - case objectFieldValue of - Just fieldValue -> - let argumentNode = Full.Node fieldValue location' - in pure $ HashMap.insert name' argumentNode arguments - Nothing -> pure arguments - -fragmentSpread - :: Full.FragmentSpread - -> State (Replacement m) (Maybe (Fragment m)) -fragmentSpread (Full.FragmentSpread name directives' _) = do - spreadDirectives <- Definition.selection <$> directives directives' - fragments' <- gets fragments - - fragmentDefinitions' <- gets fragmentDefinitions - case HashMap.lookup name fragments' of - Just definition -> lift $ pure $ definition <$ spreadDirectives - Nothing - | Just definition <- HashMap.lookup name fragmentDefinitions' -> do - fragDef <- fragmentDefinition definition - case fragDef of - Just fragment -> lift $ pure $ fragment <$ spreadDirectives - _ -> lift $ pure Nothing - | otherwise -> lift $ pure Nothing - -inlineFragment - :: Full.InlineFragment - -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) -inlineFragment (Full.InlineFragment type' directives' selections _) = do - fragmentDirectives <- Definition.selection <$> directives directives' - case fragmentDirectives of - Nothing -> pure $ Left mempty - _ -> do - fragmentSelectionSet <- appendSelection selections - - case type' of - Nothing -> pure $ Left fragmentSelectionSet - Just typeName -> do - types' <- gets types - case Type.lookupTypeCondition typeName types' of - Just typeCondition -> pure $ - selectionFragment typeCondition fragmentSelectionSet - Nothing -> pure $ Left mempty - where - selectionFragment typeName = Right - . SelectionFragment - . Fragment typeName - -appendSelection :: Traversable t - => t Full.Selection - -> State (Replacement m) (Seq (Selection m)) -appendSelection = foldM go mempty - where - go acc sel = append acc <$> selection sel - append acc (Left list) = list >< acc - append acc (Right one) = one <| acc - -directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive] -directives = traverse directive - where - directive (Full.Directive directiveName directiveArguments _) - = Definition.Directive directiveName . Type.Arguments - <$> foldM go HashMap.empty directiveArguments - go arguments (Full.Argument name (Full.Node value' _) _) = do - substitutedValue <- value value' - return $ HashMap.insert name substitutedValue arguments - --- * Fragment replacement - --- | Extract fragment definitions into a single 'HashMap'. -collectFragments :: State (Replacement m) () -collectFragments = do - fragDefs <- gets fragmentDefinitions - let nextValue = head $ HashMap.elems fragDefs - unless (HashMap.null fragDefs) $ do - _ <- fragmentDefinition nextValue - collectFragments - -fragmentDefinition - :: Full.FragmentDefinition - -> State (Replacement m) (Maybe (Fragment m)) -fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do - modify deleteFragmentDefinition - fragmentSelection <- appendSelection selections - types' <- gets types - - case Type.lookupTypeCondition type' types' of - Just compositeType -> do - let newValue = Fragment compositeType fragmentSelection - modify $ insertFragment newValue - lift $ pure $ Just newValue - _ -> lift $ pure Nothing - where - deleteFragmentDefinition replacement@Replacement{..} = - let newDefinitions = HashMap.delete name fragmentDefinitions - in replacement{ fragmentDefinitions = newDefinitions } - insertFragment newValue replacement@Replacement{..} = - let newFragments = HashMap.insert name newValue fragments - in replacement{ fragments = newFragments } - -value :: forall m. Full.Value -> State (Replacement m) Type.Value -value (Full.Variable name) = - gets (fromMaybe Type.Null . HashMap.lookup name . variableValues) -value (Full.Int int) = pure $ Type.Int int -value (Full.Float float) = pure $ Type.Float float -value (Full.String string) = pure $ Type.String string -value (Full.Boolean boolean) = pure $ Type.Boolean boolean -value Full.Null = pure Type.Null -value (Full.Enum enum) = pure $ Type.Enum enum -value (Full.List list) = Type.List <$> traverse (value . Full.node) list -value (Full.Object object) = - Type.Object . HashMap.fromList <$> traverse objectField object - where - objectField Full.ObjectField{value = value', ..} = - (name,) <$> value (Full.node value') - -input :: forall m. Full.Value -> State (Replacement m) (Maybe Input) -input (Full.Variable name) = - gets (fmap Variable . HashMap.lookup name . variableValues) -input (Full.Int int) = pure $ pure $ Int int -input (Full.Float float) = pure $ pure $ Float float -input (Full.String string) = pure $ pure $ String string -input (Full.Boolean boolean) = pure $ pure $ Boolean boolean -input Full.Null = pure $ pure Null -input (Full.Enum enum) = pure $ pure $ Enum enum -input (Full.List list) = pure . List <$> traverse (value . Full.node) list -input (Full.Object object) = do - objectFields <- foldM objectField HashMap.empty object - pure $ pure $ Object objectFields - where - objectField resultMap Full.ObjectField{value = value', ..} = - inputField resultMap name $ Full.node value' - -inputField :: forall m - . HashMap Full.Name Input - -> Full.Name - -> Full.Value - -> State (Replacement m) (HashMap Full.Name Input) -inputField resultMap name value' = do - objectFieldValue <- input value' - case objectFieldValue of - Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap - Nothing -> pure resultMap diff --git a/src/Language/GraphQL/Executor.hs b/src/Language/GraphQL/Executor.hs deleted file mode 100644 index 39428d5..0000000 --- a/src/Language/GraphQL/Executor.hs +++ /dev/null @@ -1,847 +0,0 @@ -{- 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 #-} - -module Language.GraphQL.Executor - ( Error(..) - , Operation(..) - , Path(..) - , ResponseEventStream - , Response(..) - , execute - ) where - -import Conduit (ConduitT, 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 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 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(..)) - -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 - | 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 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' = - executeRequest schema' document' (Text.unpack <$> operationName) subs - -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 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 - -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 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) - -> 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') - -type ResponseEventStream m a = ConduitT () (Response a) m () - -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 (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 - -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 diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 076b38e..cbfeeeb 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Types that can be used as both input and output types. module Language.GraphQL.Type.Definition diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index d42599b..376ed6f 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} -- | Input types and values. diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index daa816d..e4739d6 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -54,18 +54,23 @@ queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList [ ("philosopher", ValueResolver philosopherField philosopherResolver) , ("genres", ValueResolver genresField genresResolver) + , ("count", ValueResolver countField countResolver) ] where philosopherField = - Out.Field Nothing (Out.NonNullObjectType philosopherType) + Out.Field Nothing (Out.NamedObjectType philosopherType) $ HashMap.singleton "id" $ In.Argument Nothing (In.NamedScalarType id) Nothing philosopherResolver = pure $ Object mempty genresField = - let fieldType = Out.ListType $ Out.NonNullScalarType string - in Out.Field Nothing fieldType HashMap.empty + let fieldType = Out.ListType $ Out.NonNullScalarType string + in Out.Field Nothing fieldType HashMap.empty genresResolver :: Resolve (Either SomeException) genresResolver = throwM PhilosopherException + countField = + let fieldType = Out.NonNullScalarType int + in Out.Field Nothing fieldType HashMap.empty + countResolver = pure "" musicType :: Out.ObjectType (Either SomeException) musicType = Out.ObjectType "Music" Nothing [] @@ -230,9 +235,7 @@ spec = it "errors on invalid output enum values" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "school" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error { message = @@ -247,9 +250,7 @@ spec = it "gives location information for non-null unions" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "interest" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error { message = @@ -264,9 +265,7 @@ spec = it "gives location information for invalid interfaces" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "majorWork" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error { message @@ -297,14 +296,12 @@ spec = it "gives location information for failed result coercion" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "century" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Result coercion failed." + { message = "Unable to coerce result to !Int." , locations = [Location 1 26] - , path = [] + , path = [Segment "philosopher", Segment "century"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' @@ -318,13 +315,24 @@ spec = executionErrors = pure $ Error { message = "PhilosopherException" , locations = [Location 1 3] - , path = [] + , path = [Segment "genres"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' $ parse document "" "{ genres }" in actual `shouldBe` expected + it "sets data to null if a root field isn't nullable" $ + let executionErrors = pure $ Error + { message = "Unable to coerce result to !Int." + , locations = [Location 1 3] + , path = [Segment "count"] + } + expected = Response Aeson.Null executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ count }" + in actual `shouldBe` expected + context "Subscription" $ it "subscribes" $ let data'' = Aeson.object