diff options
Diffstat (limited to 'src/Language/GraphQL')
| -rw-r--r-- | src/Language/GraphQL/AST.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/DirectiveLocation.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/Error.hs | 79 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 723 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 253 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Internal.hs | 31 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Subscribe.hs | 113 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 610 | ||||
| -rw-r--r-- | src/Language/GraphQL/TH.hs | 38 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Definition.hs | 31 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/In.hs | 1 |
11 files changed, 1058 insertions, 829 deletions
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/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index 511225f..d109666 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -1,7 +1,3 @@ -{- 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 #-} -- | Various parts of a GraphQL document can be annotated with directives. diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 2061c20..4e461f0 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 #-} @@ -40,12 +44,6 @@ import Text.Megaparsec , unPos ) --- | Executor context. -data Resolution m = Resolution - { errors :: Seq Error - , types :: HashMap Name (Schema.Type m) - } - -- | Wraps a parse error into a list of errors. parseError :: (Applicative f, Serialize a) => ParseErrorBundle Text Void @@ -65,32 +63,6 @@ parseError ParseErrorBundle{..} = sourcePosition = pstateSourcePos newState in (result |> errorObject x sourcePosition, newState) --- | A wrapper to pass error messages around. -type CollectErrsT m = StateT (Resolution m) m - --- | Adds an error to the list of errors. -{-# DEPRECATED #-} -addErr :: Monad m => Error -> CollectErrsT m () -addErr v = modify appender - where - appender :: Monad m => Resolution m -> Resolution m - appender resolution@Resolution{..} = resolution{ errors = errors |> v } - -{-# DEPRECATED #-} -makeErrorMessage :: Text -> Error -makeErrorMessage s = Error s [] [] - --- | Constructs a response object containing only the error with the given --- message. -{-# DEPRECATED #-} -singleError :: Serialize a => Text -> Response a -singleError message = Response null $ Seq.singleton $ Error message [] [] - --- | Convenience function for just wrapping an error message. -{-# DEPRECATED #-} -addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a -addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null - -- | If an error can be associated to a particular field in the GraphQL result, -- it must contain an entry with the key path that details the path of the -- response field which experienced the error. This allows clients to identify @@ -129,8 +101,13 @@ instance Show ResolverException where instance Exception ResolverException +-- * Deprecated + -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data. +-- +-- /runCollectErrs was part of the old executor and isn't used anymore, it will +-- be deprecated in the future and removed./ runCollectErrs :: (Monad m, Serialize a) => HashMap Name (Schema.Type m) -> CollectErrsT m a @@ -139,3 +116,41 @@ runCollectErrs types' res = do (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = Seq.empty, types = types' } pure $ Response dat errors + +-- | Executor context. +-- +-- /Resolution was part of the old executor and isn't used anymore, it will be +-- deprecated in the future and removed./ +data Resolution m = Resolution + { errors :: Seq Error + , types :: HashMap Name (Schema.Type m) + } + +-- | A wrapper to pass error messages around. +-- +-- /CollectErrsT was part of the old executor and isn't used anymore, it will be +-- deprecated in the future and removed./ +type CollectErrsT m = StateT (Resolution m) m + +-- | Adds an error to the list of errors. +{-# DEPRECATED #-} +addErr :: Monad m => Error -> CollectErrsT m () +addErr v = modify appender + where + appender :: Monad m => Resolution m -> Resolution m + appender resolution@Resolution{..} = resolution{ errors = errors |> v } + +{-# DEPRECATED #-} +makeErrorMessage :: Text -> Error +makeErrorMessage s = Error s [] [] + +-- | Constructs a response object containing only the error with the given +-- message. +{-# DEPRECATED #-} +singleError :: Serialize a => Text -> Response a +singleError message = Response null $ Seq.singleton $ Error message [] [] + +-- | Convenience function for just wrapping an error message. +{-# DEPRECATED #-} +addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a +addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 62754a3..476cc50 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,4 +1,13 @@ -{-# LANGUAGE ExplicitForAll #-} +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute @@ -6,27 +15,210 @@ module Language.GraphQL.Execute , module Language.GraphQL.Execute.Coerce ) where -import Control.Monad.Catch (MonadCatch) +import Conduit (mapMC, (.|)) +import Control.Arrow (left) +import Control.Monad.Catch + ( Exception(..) + , Handler(..) + , MonadCatch(..) + , MonadThrow(..) + , SomeException(..) + , catches + ) +import Control.Monad.Trans.Class (MonadTrans(..)) +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.Foldable (find) import Data.HashMap.Strict (HashMap) -import Data.Sequence (Seq(..)) +import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq import Data.Text (Text) -import qualified Language.GraphQL.AST.Document as Full +import qualified Data.Text as Text +import Data.Typeable (cast) +import GHC.Records (HasField(..)) import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Execution -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.Execute.Subscribe as Subscribe +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 - , ResponseEventStream + ( Error(..) , Response(..) - , runCollectErrs + , Path(..) + , ResolverException(..) + , ResponseEventStream ) -import qualified Language.GraphQL.Type.Definition as Definition -import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema import Prelude hiding (null) +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 ResultException = forall e. Exception e => ResultException e + +instance Show ResultException where + show (ResultException e) = show e + +instance Exception ResultException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +resultExceptionToException :: Exception e => e -> SomeException +resultExceptionToException = toException . ResultException + +resultExceptionFromException :: Exception e => SomeException -> Maybe e +resultExceptionFromException e = do + ResultException resultException <- fromException e + cast resultException + +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 + +data ValueCompletionException = ValueCompletionException String Type.Value + +instance Show ValueCompletionException where + show (ValueCompletionException typeRepresentation found) = concat + [ "Value completion error. Expected type " + , typeRepresentation + , ", found: " + , show found + , "." + ] + +instance Exception ValueCompletionException where + toException = resultExceptionToException + fromException = resultExceptionFromException + +data InputCoercionException = + InputCoercionException String In.Type (Maybe (Full.Node Transform.Input)) + +instance Show InputCoercionException where + show (InputCoercionException argumentName argumentType Nothing) = concat + [ "Required argument \"" + , argumentName + , "\" of type " + , show argumentType + , " not specified." + ] + show (InputCoercionException argumentName argumentType (Just givenValue)) = concat + [ "Argument \"" + , argumentName + , "\" has invalid type. Expected type " + , show argumentType + , ", found: " + , show givenValue + , "." + ] + +instance Exception InputCoercionException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +newtype ResultCoercionException = ResultCoercionException String + +instance Show ResultCoercionException where + show (ResultCoercionException typeRepresentation) = concat + [ "Unable to coerce result to " + , typeRepresentation + , "." + ] + +instance Exception ResultCoercionException where + toException = resultExceptionToException + fromException = resultExceptionFromException + +-- | Query error types. +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 = + 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 = [] } + -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document -- defines multiple root operations. @@ -39,33 +231,492 @@ execute :: (MonadCatch m, VariableValue a, Serialize b) -> HashMap Full.Name a -- ^ Variable substitution function. -> Full.Document -- @GraphQL@ document. -> m (Either (ResponseEventStream m b) (Response b)) -execute schema' operationName subs document - = either (pure . rightErrorResponse . singleError [] . show) executeRequest - $ Transform.document schema' operationName subs document +execute schema' operationName subs document' = + executeRequest schema' document' (Text.unpack <$> operationName) subs -executeRequest :: (MonadCatch m, Serialize a) - => Transform.Document m +executeRequest :: (MonadCatch m, Serialize a, VariableValue b) + => Schema m + -> Full.Document + -> Maybe String + -> HashMap Full.Name b -> m (Either (ResponseEventStream m a) (Response a)) -executeRequest (Transform.Document types' rootObjectType operation) - | (Transform.Query _ fields objectLocation) <- operation = - Right <$> executeOperation types' rootObjectType objectLocation fields - | (Transform.Mutation _ fields objectLocation) <- operation = - Right <$> executeOperation types' rootObjectType objectLocation fields - | (Transform.Subscription _ fields objectLocation) <- operation - = either rightErrorResponse Left - <$> Subscribe.subscribe types' rootObjectType objectLocation fields - --- This is actually executeMutation, but we don't distinguish between queries --- and mutations yet. -executeOperation :: (MonadCatch m, Serialize a) +executeRequest schema sourceDocument operationName variableValues = do + operationAndVariables <- sequence buildOperation + case operationAndVariables of + Left queryError' -> pure + $ Right + $ Response null $ pure $ queryError queryError' + Right operation + | Transform.Operation Full.Query topSelections _operationLocation <- operation -> + Right <$> executeQuery topSelections schema + | Transform.Operation Full.Mutation topSelections operationLocation <- operation -> + Right <$> executeMutation topSelections schema operationLocation + | Transform.Operation Full.Subscription topSelections operationLocation <- operation -> + either rightErrorResponse Left <$> subscribe topSelections schema operationLocation + where + schemaTypes = Schema.types schema + (operationDefinitions, fragmentDefinitions') = + Transform.document sourceDocument + buildOperation = do + operationDefinition <- getOperation operationDefinitions operationName + coercedVariableValues <- coerceVariableValues + schemaTypes + operationDefinition + variableValues + let replacement = Transform.Replacement + { variableValues = coercedVariableValues + , fragmentDefinitions = fragmentDefinitions' + , visitedFragments = mempty + , types = schemaTypes + } + pure $ flip runReaderT replacement + $ Transform.runTransformT + $ Transform.transform operationDefinition + +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 +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, Serialize a) + => Seq (Transform.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 + $ catch (executeSelectionSet topSelections queryType Type.Null []) + handleException + pure $ Response data' errors + +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) +executeMutation topSelections schema operationLocation + | Just mutationType <- Schema.mutation schema = do + (data', errors) <- runWriterT + $ flip runReaderT (Schema.types schema) + $ runExecutorT + $ catch (executeSelectionSet topSelections mutationType Type.Null []) + handleException + pure $ Response data' errors + | otherwise = pure + $ Response null + $ Seq.singleton + $ Error "Schema doesn't support mutations." [operationLocation] [] + +executeSelectionSet :: (MonadCatch m, Serialize a) + => Seq (Transform.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) $ Object resolvedValues + where + executeField' fields resolver = + executeField objectValue fields resolver errorPath + Out.ObjectType _ _ _ resolvers = objectType + go fields@(Transform.Field _ fieldName _ _ _ :| _) = + traverse (executeField' fields) $ HashMap.lookup fieldName resolvers + +fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path +fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) = + Segment (fromMaybe fieldName alias) + +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 (Transform.Field m) + -> Out.Resolver m + -> [Path] + -> ExecutorT m a +executeField objectValue fields (viewResolver -> resolverPair) errorPath = + let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields + in catches (go fieldName inputArguments) + [ Handler nullResultHandler + , Handler (inputCoercionHandler fieldLocation) + , Handler (resultHandler fieldLocation) + , Handler (resolverHandler fieldLocation) + ] + where + inputCoercionHandler :: (MonadCatch m, Serialize a) + => Full.Location + -> InputCoercionException + -> ExecutorT m a + inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = + let argumentLocation = getField @"location" valueNode + in exceptionHandler argumentLocation e + inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e + resultHandler :: (MonadCatch m, Serialize a) + => Full.Location + -> ResultException + -> ExecutorT m a + 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 + argumentValues <- coerceArgumentValues argumentTypes inputArguments + resolvedValue <- + resolveFieldValue resolveFunction objectValue fieldName argumentValues + completeValue fieldType fields errorPath resolvedValue + (resolverField, resolveFunction) = resolverPair + Out.Field _ fieldType argumentTypes = resolverField + +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, Serialize a) + => Out.Type m + -> NonEmpty (Transform.Field m) + -> [Path] + -> Type.Value + -> ExecutorT m a +completeValue (Out.isNonNullType -> False) _ _ Type.Null = + pure null +completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list) + = 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 $ Int int +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) = + coerceResult outputType $ Boolean boolean +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) = + coerceResult outputType $ Float float +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.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 $ Enum enum + else throwM + $ ValueCompletionException (show outputType) + $ Type.Enum enum +completeValue (Out.ObjectBaseType objectType) fields errorPath result + = executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath +completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result + | Type.Object objectMap <- result = do + let abstractType = Type.Internal.AbstractInterfaceType interfaceType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType + -> executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath + Nothing -> throwM + $ ValueCompletionException (show outputType) result +completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result + | Type.Object objectMap <- result = do + let abstractType = Type.Internal.AbstractUnionType unionType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType + -> executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath + Nothing -> throwM + $ ValueCompletionException (show outputType) result +completeValue outputType _ _ result = + throwM $ ValueCompletionException (show outputType) result + +coerceResult :: (MonadCatch m, Serialize a) + => Out.Type m + -> Output a + -> ExecutorT m a +coerceResult outputType result + | Just serialized <- serialize outputType result = pure serialized + | otherwise = throwM $ ResultCoercionException $ show outputType + +mergeSelectionSets :: MonadCatch m + => NonEmpty (Transform.Field m) + -> Seq (Transform.Selection m) +mergeSelectionSets = foldr forEach mempty + where + forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet' = + selectionSet' <> fieldSelectionSet + +coerceArgumentValues :: MonadCatch m + => HashMap Full.Name In.Argument + -> HashMap Full.Name (Full.Node Transform.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 inputValue <- HashMap.lookup argumentName argumentValues + -> throwM + $ InputCoercionException (Text.unpack argumentName) variableType + $ Just inputValue + | otherwise -> throwM + $ InputCoercionException (Text.unpack argumentName) variableType Nothing + matchFieldValues' = matchFieldValues coerceArgumentValue + $ Full.node <$> argumentValues + 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 = coerceArgumentValue 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 + +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.FieldSelection fieldSelection) = + let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection + responseKey = fromMaybe fieldName maybeAlias + in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields + 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, 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 + $ matchFieldValues + coerceVariableValue' + variableValues + variableName + variableType + defaultValue' + $ Just coercedValues + Nothing -> Left $ UnknownInputType variableDefinition + forEach _ coercedValuesOrError = coercedValuesOrError + coerceVariableValue' variableType value' + = coerceVariableValue variableType value' + >>= coerceInputLiteral variableType + +constValue :: Full.ConstValue -> Type.Value +constValue (Full.ConstInt i) = Type.Int i +constValue (Full.ConstFloat f) = Type.Float f +constValue (Full.ConstString x) = Type.String x +constValue (Full.ConstBoolean b) = Type.Boolean b +constValue Full.ConstNull = Type.Null +constValue (Full.ConstEnum e) = Type.Enum e +constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list +constValue (Full.ConstObject o) = + Type.Object $ HashMap.fromList $ constObjectField <$> o + where + constObjectField Full.ObjectField{value = value', ..} = + (name, constValue $ Full.node value') + +subscribe :: (MonadCatch m, Serialize a) + => Seq (Transform.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, Serialize a) + => HashMap Full.Name (Type m) + -> Out.ObjectType m + -> Seq (Transform.Selection m) + -> Out.SourceEventStream m + -> m (ResponseEventStream m a) +mapSourceToResponseEvent types' subscriptionType fields sourceStream + = pure + $ sourceStream + .| mapMC (executeSubscriptionEvent types' subscriptionType fields) + +createSourceEventStream :: MonadCatch m => HashMap Full.Name (Type m) -> Out.ObjectType m -> Full.Location -> Seq (Transform.Selection m) - -> m (Response a) -executeOperation types' objectType objectLocation fields - = runCollectErrs types' - $ executeSelectionSet Definition.Null objectType objectLocation fields + -> 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 + singleError :: [Full.Location] -> String -> Error + singleError errorLocations message = Error (Text.pack message) errorLocations [] -rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b) -rightErrorResponse = Right . Response null . pure +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 + -> Seq (Transform.Selection m) + -> Type.Value + -> m (Response a) +executeSubscriptionEvent types' objectType fields initialValue = do + (data', errors) <- runWriterT + $ flip runReaderT types' + $ runExecutorT + $ 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/Internal.hs b/src/Language/GraphQL/Execute/Internal.hs deleted file mode 100644 index 046db45..0000000 --- a/src/Language/GraphQL/Execute/Internal.hs +++ /dev/null @@ -1,31 +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 DuplicateRecordFields #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Language.GraphQL.Execute.Internal - ( addError - , singleError - ) where - -import Control.Monad.Trans.State (modify) -import Control.Monad.Catch (MonadCatch) -import Data.Sequence ((|>)) -import qualified Data.Text as Text -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..)) -import Prelude hiding (null) - -addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a -addError returnValue error' = modify appender >> pure returnValue - where - appender :: Resolution m -> Resolution m - appender resolution@Resolution{ errors } = resolution - { errors = errors |> error' - } - -singleError :: [Full.Location] -> String -> Error -singleError errorLocations message = Error (Text.pack message) errorLocations [] 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..79de094 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,87 @@ -- 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 + +-- | Field or inlined fragment. +data Selection m + = FieldSelection (Field m) + | FragmentSelection (Fragment m) --- | Single GraphQL field. data Field m = Field (Maybe Full.Name) Full.Name @@ -87,339 +109,217 @@ 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) - -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 - where - matchingName (OperationDefinition _ name _ _ _ _) = - name == Just operationName - -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 + | 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 + +-- | Extracts operations and fragment definitions of the document. +document :: Full.Document + -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition) +document = foldr filterOperation ([], HashMap.empty) where - forEach variableDefinition coercedValues = do - let Full.VariableDefinition variableName variableTypeName defaultValue _ = - variableDefinition - let defaultValue' = constValue . Full.node <$> defaultValue - variableType <- Type.lookupInputType variableTypeName types - - Coerce.matchFieldValues - coerceVariableValue' - variableValues - variableName - variableType - defaultValue' - coercedValues - 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') + 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. -- | 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 - -> HashMap Full.Name a - -> Full.Document - -> Either QueryError (Document m) -document schema operationName subs ast = do - let referencedTypes = Schema.types schema - - (operations, fragmentTable) <- defragment ast - chosenOperation <- getOperation operationName operations - coercedValues <- coerceVariableValues referencedTypes chosenOperation subs - - 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 +-- for the query execution. +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 - 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 + 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 [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 - 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 + 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 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 + 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 - 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 + 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 - 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 + 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 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 + 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 + diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs new file mode 100644 index 0000000..b6bc18c --- /dev/null +++ b/src/Language/GraphQL/TH.hs @@ -0,0 +1,38 @@ +{- 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/. -} + +-- | Template Haskell helpers. +module Language.GraphQL.TH + ( gql + ) where + +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH (Exp(..), Lit(..)) + +stripIndentation :: String -> String +stripIndentation code = reverse + $ dropNewlines + $ reverse + $ unlines + $ indent spaces <$> lines withoutLeadingNewlines + where + indent 0 xs = xs + indent count (' ' : xs) = indent (count - 1) xs + indent _ xs = xs + withoutLeadingNewlines = dropNewlines code + dropNewlines = dropWhile (== '\n') + spaces = length $ takeWhile (== ' ') withoutLeadingNewlines + +-- | Removes leading and trailing newlines. Indentation of the first line is +-- removed from each line of the string. +gql :: QuasiQuoter +gql = QuasiQuoter + { quoteExp = pure . LitE . StringL . stripIndentation + , quotePat = const + $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = const + $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = const + $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)" + } diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 6ca77aa..1c8876a 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -1,4 +1,9 @@ +{- 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 OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Types that can be used as both input and output types. module Language.GraphQL.Type.Definition @@ -20,10 +25,12 @@ module Language.GraphQL.Type.Definition import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.List (intercalate) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text -import Language.GraphQL.AST (Name) +import Language.GraphQL.AST (Name, escape) +import Numeric (showFloat) import Prelude hiding (id) -- | Represents accordingly typed GraphQL values. @@ -36,7 +43,27 @@ data Value | Enum Name | List [Value] -- ^ Arbitrary nested list. | Object (HashMap Name Value) - deriving (Eq, Show) + deriving Eq + +instance Show Value 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 . 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 instance IsString Value where fromString = String . fromString 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. |