diff --git a/server/src-lib/Hasura/GraphQL/Execute.hs b/server/src-lib/Hasura/GraphQL/Execute.hs index 872797acbbb..470aaff7984 100644 --- a/server/src-lib/Hasura/GraphQL/Execute.hs +++ b/server/src-lib/Hasura/GraphQL/Execute.hs @@ -395,8 +395,10 @@ getResolvedExecPlan let parameterizedQueryHash = calculateParameterizedQueryHash normalizedSelectionSet -- Process directives on the subscription dirMap <- - (`onLeft` reportParseErrors) - =<< runParseT (parseDirectives customDirectives (G.DLExecutable G.EDLSUBSCRIPTION) normalizedDirectives) + liftEither $ + runParse (parseDirectives customDirectives (G.DLExecutable G.EDLSUBSCRIPTION) normalizedDirectives) + `onLeft` reportParseErrors + -- A subscription should have exactly one root field. -- However, for testing purposes, we may allow several root fields; we check for this by -- looking for directive "_multiple_top_level_fields" on the subscription. THIS IS NOT A diff --git a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs index c4aeacbd15f..3bcf75fd28b 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs @@ -112,8 +112,9 @@ convertMutationSelectionSet -- Process directives on the mutation _dirMap <- - (`onLeft` reportParseErrors) - =<< runParseT (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives) + liftEither $ + runParse (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives) + `onLeft` reportParseErrors let parameterizedQueryHash = calculateParameterizedQueryHash resolvedSelSet diff --git a/server/src-lib/Hasura/GraphQL/Execute/Query.hs b/server/src-lib/Hasura/GraphQL/Execute/Query.hs index 34c2b93558d..c5ec45fad61 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Query.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Query.hs @@ -96,8 +96,9 @@ convertQuerySelSet -- 2. Parse directives on the query dirMap <- - (`onLeft` reportParseErrors) - =<< runParseT (parseDirectives customDirectives (G.DLExecutable G.EDLQUERY) normalizedDirectives) + liftEither + (runParse (parseDirectives customDirectives (G.DLExecutable G.EDLQUERY) normalizedDirectives)) + `onLeft` reportParseErrors let parameterizedQueryHash = calculateParameterizedQueryHash normalizedSelectionSet diff --git a/server/src-lib/Hasura/GraphQL/Parser/Monad.hs b/server/src-lib/Hasura/GraphQL/Parser/Monad.hs index 7435f6d2929..8bdee9a7cc5 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Monad.hs +++ b/server/src-lib/Hasura/GraphQL/Parser/Monad.hs @@ -2,13 +2,14 @@ module Hasura.GraphQL.Parser.Monad ( SchemaT, runSchemaT, - ParseT, - runParseT, + Parse, + runParse, ParseError (..), reportParseErrors, ) where +import Control.Monad.Except import Data.Dependent.Map (DMap) import Data.Dependent.Map qualified as DM import Data.GADT.Compare.Extended @@ -160,25 +161,22 @@ newtype instance ParserById m '(p, a) = ParserById (p m a) -- ------------------------------------------------------------------------------------------------- -- query parsing -newtype ParseT m a = ParseT - { unParseT :: ReaderT JSONPath (ExceptT ParseError m) a +newtype Parse a = Parse + { unParse :: ReaderT JSONPath (Except ParseError) a } deriving (Functor, Applicative, Monad) -runParseT :: - ParseT m a -> - m (Either ParseError a) -runParseT = - unParseT +runParse :: + Parse a -> + Either ParseError a +runParse = + unParse >>> flip runReaderT [] - >>> runExceptT + >>> runExcept -instance MonadTrans ParseT where - lift = ParseT . lift . lift - -instance Monad m => MonadParse (ParseT m) where - withPath f x = ParseT $ withReaderT f $ unParseT x - parseErrorWith code text = ParseT $ do +instance MonadParse Parse where + withPath f x = Parse $ withReaderT f $ unParse x + parseErrorWith code text = Parse $ do path <- ask lift $ throwError $ ParseError {peCode = code, pePath = path, peMessage = text} diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index 4c0339c6f88..21cf69df5f4 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -21,7 +21,7 @@ import Data.Text qualified as T import Data.Text.Extended (dquoteList, (<<>)) import Hasura.Base.Error import Hasura.GraphQL.Parser.Constants qualified as G -import Hasura.GraphQL.Parser.Monad (ParseT, runSchemaT) +import Hasura.GraphQL.Parser.Monad (Parse, runSchemaT) import Hasura.GraphQL.Schema.Common import Hasura.GraphQL.Schema.Remote (buildRemoteParser) import Hasura.GraphQL.Transport.HTTP.Protocol @@ -80,7 +80,7 @@ fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do void $ flip runReaderT minimumValidContext $ runSchemaT $ - buildRemoteParser @_ @_ @(ParseT Identity) + buildRemoteParser @_ @_ @Parse _rscIntroOriginal _rscRemoteRelationships _rscInfo @@ -256,14 +256,14 @@ validateSchemaCustomizationsDistinct remoteSchemaCustomizer (RemoteSchemaIntrosp validateFieldMappingsAreDistinct :: G.TypeDefinition a b -> m () validateFieldMappingsAreDistinct = \case G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} -> do - let dups = duplicates $ (customizeFieldName _itdName . G._fldName) <$> _itdFieldsDefinition + let dups = duplicates $ customizeFieldName _itdName . G._fldName <$> _itdFieldsDefinition unless (Set.null dups) $ throwRemoteSchema $ "Field name mappings for interface type " <> _itdName <<> " are not distinct; the following fields appear more than once: " <> dquoteList dups G.TypeDefinitionObject G.ObjectTypeDefinition {..} -> do - let dups = duplicates $ (customizeFieldName _otdName . G._fldName) <$> _otdFieldsDefinition + let dups = duplicates $ customizeFieldName _otdName . G._fldName <$> _otdFieldsDefinition unless (Set.null dups) $ throwRemoteSchema $ "Field name mappings for object type " <> _otdName diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index 2d0e4f0b2bf..ec08a2b0dac 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -260,10 +260,10 @@ buildRoleContext options sources remotes allActionInfos customTypes role remoteS SourceInfo b -> ConcreteSchemaT m - ( [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))], - [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))], - [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))], - [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))] + ( [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))], + [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))], + [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))], + [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))] ) buildSource sourceInfo@(SourceInfo _ tables functions _ _ sourceCustomization') = withSourceCustomization sourceCustomization (namingConventionSupport @b) globalDefaultNC do @@ -378,10 +378,10 @@ buildRelayRoleContext options sources allActionInfos customTypes role expFeature SourceInfo b -> ConcreteSchemaT m - ( [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))], - [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))], - [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))], - [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))] + ( [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))], + [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))], + [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))], + [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))] ) buildSource sourceInfo@(SourceInfo _ tables functions _ _ sourceCustomization') = withSourceCustomization sourceCustomization (namingConventionSupport @b) globalDefaultNC do @@ -496,11 +496,11 @@ buildAndValidateRemoteSchemas :: MonadIO m ) => HashMap RemoteSchemaName (RemoteSchemaCtx, MetadataObject) -> - [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))] -> - [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))] -> + [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))] -> + [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))] -> RoleName -> RemoteSchemaPermsCtx -> - ConcreteSchemaT m ([RemoteSchemaParser (P.ParseT Identity)], HashSet InconsistentMetadata) + ConcreteSchemaT m ([RemoteSchemaParser P.Parse], HashSet InconsistentMetadata) buildAndValidateRemoteSchemas remotes sourcesQueryFields sourcesMutationFields role remoteSchemaPermsCtx = runWriterT $ foldlM step [] (Map.elems remotes) where @@ -551,7 +551,7 @@ buildRemoteSchemaParser :: RemoteSchemaPermsCtx -> RoleName -> RemoteSchemaCtx -> - ConcreteSchemaT m (Maybe (RemoteSchemaParser (P.ParseT Identity))) + ConcreteSchemaT m (Maybe (RemoteSchemaParser P.Parse)) buildRemoteSchemaParser remoteSchemaPermsCtx roleName context = do let maybeIntrospection = getIntrospectionResult remoteSchemaPermsCtx roleName context for maybeIntrospection \introspection -> @@ -668,7 +668,7 @@ buildMutationFields scenario sourceInfo tables (takeExposedAs FEAMutation -> fun guard $ -- when function permissions are inferred, we don't expose the -- mutation functions for non-admin roles. See Note [Function Permissions] - roleName == adminRoleName || roleName `Map.member` (_fiPermissions functionInfo) + roleName == adminRoleName || roleName `Map.member` _fiPermissions functionInfo lift $ mkRFs MDBR $ buildFunctionMutationFields sourceInfo functionName functionInfo targetTableName pure $ concat $ tableMutations <> catMaybes functionMutations where @@ -835,8 +835,8 @@ mkRootFields :: SourceConfig b -> Maybe QueryTagsConfig -> (a -> db b) -> - m [(FieldParser n a)] -> - m [(FieldParser n (RootField db remote action raw))] + m [FieldParser n a] -> + m [FieldParser n (RootField db remote action raw)] mkRootFields sourceName sourceConfig queryTagsConfig inj = fmap ( map @@ -855,12 +855,12 @@ mutationRoot = G._mutation_root queryRoot :: G.Name queryRoot = G._query_root -finalizeParser :: Parser 'Output (P.ParseT Identity) a -> ParserFn a -finalizeParser parser = runIdentity . P.runParseT . P.runParser parser +finalizeParser :: Parser 'Output P.Parse a -> ParserFn a +finalizeParser parser = P.runParse . P.runParser parser type ConcreteSchemaT m a = P.SchemaT - (P.ParseT Identity) + P.Parse ( ReaderT ( SchemaOptions, SchemaContext, diff --git a/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs b/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs index e6d34ebdc50..73fe8411229 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs @@ -206,9 +206,9 @@ buildIntrospectionSchema queryRoot' mutationRoot' subscriptionRoot' = do let -- The only directives that we currently expose over introspection are our -- statically defined ones. So, for instance, we don't correctly expose -- directives from remote schemas. - directives = directivesInfo @(P.ParseT Identity) + directives = directivesInfo @P.Parse -- The __schema and __type introspection fields - introspection = [schema @(P.ParseT Identity), typeIntrospection] + introspection = [schema @P.Parse, typeIntrospection] {-# INLINE introspection #-} -- Collect type information of all non-introspection fields