server: Remove QErr and Code dependencies from the schema parsers.

In the process of decoupling the schema parsers from the GraphQL Engine, we need to remove dependencies on `Hasura.Base.Error`.

First of all, we have avoided using `QErr` in schema parsers code, instead returning a more appropriate data type which can be converted to a `Hasura.Base.Error.QErr` later.

Secondly, we create a new `ParseErrorCode` type to represent parse failure types, which are then converted to a `Hasura.Base.Error.Code` later.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/5181
GitOrigin-RevId: 8655e26adb1e7d5e3d552c77a8a403f987b53467

server/graphql-engine.cabal

@@ -799,6 +799,7 @@ library
                      , Hasura.GraphQL.Parser.Collect
                      , Hasura.GraphQL.Parser.DirectiveName
                      , Hasura.GraphQL.Parser.Directives
+                     , Hasura.GraphQL.Parser.ErrorCode
                      , Hasura.GraphQL.Parser.Internal.Convert
                      , Hasura.GraphQL.Parser.Internal.Input
                      , Hasura.GraphQL.Parser.Internal.Parser
@@ -1057,6 +1058,7 @@ test-suite graphql-engine-tests
     Hasura.GraphQL.NamespaceSpec
     Hasura.GraphQL.Parser.DirectivesTest
     Hasura.GraphQL.Parser.MonadParseTest
+    Hasura.GraphQL.Parser.TestInstances
     Hasura.GraphQL.Parser.TestUtils
     Hasura.GraphQL.Schema.Build.UpdateSpec
     Hasura.GraphQL.Schema.RemoteTest

server/src-lib/Hasura/Backends/BigQuery/Instances/Schema.hs

@@ -217,7 +217,7 @@ bqColumnParser columnType (G.Nullability isNullable) =
             { pType = schemaType,
               pParser =
                 P.valueToJSON (P.toGraphQLType schemaType)
-                  >=> either (P.parseErrorWith ParseFailed . toErrorMessage . qeError) pure . runAesonParser J.parseJSON
+                  >=> either (P.parseErrorWith P.ParseFailed . toErrorMessage . qeError) pure . runAesonParser J.parseJSON
             }
     stringBased :: MonadParse m => G.Name -> Parser 'Both m Text
     stringBased scalarName =

server/src-lib/Hasura/Backends/MSSQL/Instances/Schema.hs

@@ -289,7 +289,7 @@ msColumnParser columnType (G.Nullability isNullable) =
               { pType = schemaType,
                 pParser =
                   P.valueToJSON (P.toGraphQLType schemaType)
-                    >=> either (P.parseErrorWith ParseFailed . toErrorMessage . qeError) pure . (MSSQL.parseScalarValue scalarType)
+                    >=> either (P.parseErrorWith P.ParseFailed . toErrorMessage . qeError) pure . (MSSQL.parseScalarValue scalarType)
               }
     ColumnEnumReference enumRef@(EnumReference _ enumValues _) ->
       case nonEmpty (Map.toList enumValues) of

server/src-lib/Hasura/Backends/MySQL/Instances/Schema.hs

@@ -202,7 +202,7 @@ columnParser' columnType (GQL.Nullability isNullable) =
             { pType = schemaType,
               pParser =
                 P.valueToJSON (P.toGraphQLType schemaType)
-                  >=> either (P.parseErrorWith ParseFailed . toErrorMessage . qeError) pure . (MySQL.parseScalarValue scalarType)
+                  >=> either (P.parseErrorWith P.ParseFailed . toErrorMessage . qeError) pure . (MySQL.parseScalarValue scalarType)
             }
     ColumnEnumReference enumRef@(EnumReference _ enumValues _) ->
       case nonEmpty (HM.toList enumValues) of

server/src-lib/Hasura/Backends/Postgres/Instances/Schema.hs

@@ -377,7 +377,7 @@ columnParser columnType (G.Nullability isNullable) = do
                   J.Null -> P.parseError $ "unexpected null value for type " <> toErrorValue name
                   value ->
                     runAesonParser (parsePGValue scalarType) value
-                      `onLeft` (P.parseErrorWith ParseFailed . toErrorMessage . qeError)
+                      `onLeft` (P.parseErrorWith P.ParseFailed . toErrorMessage . qeError)
             }
     ColumnEnumReference (EnumReference tableName enumValues tableCustomName) ->
       case nonEmpty (Map.toList enumValues) of

server/src-lib/Hasura/Backends/Postgres/Schema/Select.hs

@@ -21,8 +21,6 @@ import Hasura.Backends.Postgres.SQL.Types qualified as PG
 import Hasura.Backends.Postgres.Types.ComputedField qualified as PG
 import Hasura.Backends.Postgres.Types.Function qualified as PG
 import Hasura.Base.Error
-import Hasura.GraphQL.Parser qualified as P
-import Hasura.GraphQL.Parser.Class
 import Hasura.GraphQL.Schema.Backend
 import Hasura.GraphQL.Schema.Common
 import Hasura.GraphQL.Schema.Options qualified as Options
@@ -30,6 +28,7 @@ import Hasura.GraphQL.Schema.Parser
   ( FieldParser,
     InputFieldsParser,
   )
+import Hasura.GraphQL.Schema.Parser qualified as P
 import Hasura.GraphQL.Schema.Select
 import Hasura.GraphQL.Schema.Table
 import Hasura.GraphQL.Schema.Typename (mkTypename)
@@ -421,10 +420,10 @@ functionArgs sourceInfo functionTrackedAs (toList -> inputArgs) = do
       IAUserProvided arg -> case Map.lookup name dictionary of
         Just parsedValue -> case PG.faName arg of
           Just _ -> pure $ Just (name, parsedValue)
-          Nothing -> parseErrorWith NotSupported "Only last set of positional arguments can be omitted"
+          Nothing -> P.parseErrorWith P.NotSupported "Only last set of positional arguments can be omitted"
         Nothing ->
           whenMaybe (not $ PG.unHasDefault $ PG.faHasDefault arg) $
-            parseErrorWith NotSupported "Non default arguments cannot be omitted"
+            P.parseErrorWith P.NotSupported "Non default arguments cannot be omitted"
 
 buildFunctionQueryFieldsPG ::
   forall r m n pgKind.

server/src-lib/Hasura/GraphQL/Execute.hs

@@ -40,8 +40,8 @@ import Hasura.GraphQL.Execute.Types qualified as ET
 import Hasura.GraphQL.Namespace
 import Hasura.GraphQL.ParameterizedQueryHash
 import Hasura.GraphQL.Parser.Directives
-import Hasura.GraphQL.Parser.Monad
 import Hasura.GraphQL.RemoteServer (execRemoteGQ)
+import Hasura.GraphQL.Schema.Parser (runParse, toQErr)
 import Hasura.GraphQL.Transport.HTTP.Protocol
 import Hasura.Logging qualified as L
 import Hasura.Metadata.Class
@@ -394,8 +394,7 @@ getResolvedExecPlan
           let parameterizedQueryHash = calculateParameterizedQueryHash normalizedSelectionSet
           -- Process directives on the subscription
           dirMap <-
-            runParse
-              (parseDirectives customDirectives (G.DLExecutable G.EDLSUBSCRIPTION) normalizedDirectives)
+            toQErr $ runParse (parseDirectives customDirectives (G.DLExecutable G.EDLSUBSCRIPTION) normalizedDirectives)
 
           -- A subscription should have exactly one root field.
           -- However, for testing purposes, we may allow several root fields; we check for this by

server/src-lib/Hasura/GraphQL/Execute/Mutation.hs

@@ -18,8 +18,8 @@ import Hasura.GraphQL.Execute.RemoteJoin.Collect qualified as RJ
 import Hasura.GraphQL.Execute.Resolve
 import Hasura.GraphQL.Namespace
 import Hasura.GraphQL.ParameterizedQueryHash
-import Hasura.GraphQL.Parser
 import Hasura.GraphQL.Parser.Directives
+import Hasura.GraphQL.Schema.Parser (runParse, toQErr)
 import Hasura.GraphQL.Transport.HTTP.Protocol qualified as GH
 import Hasura.Logging qualified as L
 import Hasura.Metadata.Class
@@ -111,9 +111,7 @@ convertMutationSelectionSet
       liftEither $ mutationParser resolvedSelSet
 
     -- Process directives on the mutation
-    _dirMap <-
-      runParse
-        (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives)
+    _dirMap <- toQErr $ runParse (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives)
 
     let parameterizedQueryHash = calculateParameterizedQueryHash resolvedSelSet
 

server/src-lib/Hasura/GraphQL/Execute/Query.hs

@@ -20,8 +20,8 @@ import Hasura.GraphQL.Execute.RemoteJoin.Collect qualified as RJ
 import Hasura.GraphQL.Execute.Resolve
 import Hasura.GraphQL.Namespace
 import Hasura.GraphQL.ParameterizedQueryHash
-import Hasura.GraphQL.Parser
 import Hasura.GraphQL.Parser.Directives
+import Hasura.GraphQL.Schema.Parser
 import Hasura.GraphQL.Transport.HTTP.Protocol qualified as GH
 import Hasura.Logging qualified as L
 import Hasura.Prelude
@@ -95,9 +95,7 @@ convertQuerySelSet
       parseGraphQLQuery gqlContext varDefs (GH._grVariables gqlUnparsed) directives fields
 
     -- 2. Parse directives on the query
-    dirMap <-
-      runParse
-        (parseDirectives customDirectives (G.DLExecutable G.EDLQUERY) normalizedDirectives)
+    dirMap <- toQErr $ runParse (parseDirectives customDirectives (G.DLExecutable G.EDLQUERY) normalizedDirectives)
 
     let parameterizedQueryHash = calculateParameterizedQueryHash normalizedSelectionSet
 

server/src-lib/Hasura/GraphQL/Parser.hs

@@ -53,6 +53,7 @@ module Hasura.GraphQL.Parser
     jsonToGraphQL,
     valueToJSON,
     module Hasura.GraphQL.Parser.Class,
+    module Hasura.GraphQL.Parser.ErrorCode,
     module Hasura.GraphQL.Parser.Monad,
     module Hasura.GraphQL.Parser.Names,
     module Hasura.GraphQL.Parser.Schema,
@@ -62,6 +63,7 @@ where
 
 import Hasura.GraphQL.Parser.Class
 import Hasura.GraphQL.Parser.Directives
+import Hasura.GraphQL.Parser.ErrorCode
 import Hasura.GraphQL.Parser.Internal.Convert
 import Hasura.GraphQL.Parser.Internal.Parser
 import Hasura.GraphQL.Parser.Internal.Scalars

server/src-lib/Hasura/GraphQL/Parser/Class.hs

@@ -3,6 +3,7 @@ module Hasura.GraphQL.Parser.Class
   ( MonadSchema (..),
     memoize,
     MonadParse (..),
+    withPath,
     parseError,
   )
 where

server/src-lib/Hasura/GraphQL/Parser/Class/Parse.hs

@@ -2,22 +2,27 @@
 module Hasura.GraphQL.Parser.Class.Parse
   ( MonadParse (..),
     parseError,
+    withPath,
   )
 where
 
-import Data.Aeson.Types (JSONPathElement)
-import Hasura.Base.Error
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Types qualified as Aeson
 import Hasura.Base.ErrorMessage
+import Hasura.GraphQL.Parser.ErrorCode
 import Prelude
 
 -- | A class that provides functionality for parsing GraphQL queries, i.e.
 -- running a fully-constructed 'Parser'.
 class Monad m => MonadParse m where
-  withKey :: JSONPathElement -> m a -> m a
+  withKey :: Aeson.JSONPathElement -> m a -> m a
 
   -- | Not the full power of 'MonadError' because parse errors cannot be
   -- caught.
-  parseErrorWith :: Code -> ErrorMessage -> m a
+  parseErrorWith :: ParseErrorCode -> ErrorMessage -> m a
+
+withPath :: MonadParse m => Aeson.JSONPath -> m a -> m a
+withPath path action = foldr withKey action path
 
 parseError :: MonadParse m => ErrorMessage -> m a
 parseError = parseErrorWith ValidationFailed

server/src-lib/Hasura/GraphQL/Parser/ErrorCode.hs

@@ -0,0 +1,10 @@
+module Hasura.GraphQL.Parser.ErrorCode (ParseErrorCode (..)) where
+
+import Prelude
+
+data ParseErrorCode
+  = ValidationFailed
+  | ParseFailed
+  | ConflictingDefinitionsError
+  | NotSupported
+  deriving stock (Eq, Show)

server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs

@@ -15,7 +15,7 @@ where
 
 import Control.Arrow ((&&&))
 import Control.Monad (unless, when, (>=>))
-import Control.Monad.Except (MonadError)
+import Control.Monad.Except (MonadError (..))
 import Data.Aeson qualified as A
 import Data.Aeson.Key qualified as K
 import Data.Aeson.Types (JSONPathElement (Key))
@@ -31,7 +31,6 @@ import Data.Maybe qualified as Maybe
 import Data.Traversable (for)
 import Data.Type.Equality
 import Data.Void (Void)
-import Hasura.Base.Error
 import Hasura.Base.ErrorMessage
 import Hasura.Base.ToErrorValue
 import Hasura.GraphQL.Parser.Class.Parse
@@ -181,16 +180,17 @@ selectionSet name desc fields = selectionSetObject name desc fields []
 
 safeSelectionSet ::
   forall n m origin a.
-  (MonadError QErr n, MonadParse m, Eq origin, Hashable origin, ToErrorValue origin) =>
+  (MonadError ErrorMessage n, MonadParse m, Eq origin, Hashable origin, ToErrorValue origin) =>
   Name ->
   Maybe Description ->
   [FieldParser origin m a] ->
   n (Parser origin 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a)))
-safeSelectionSet name desc fields
-  | null duplicates = pure $ selectionSetObject name desc fields []
-  | otherwise = throw500 . fromErrorMessage $ case desc of
+safeSelectionSet name description fields
+  | null duplicates = pure $ selectionSetObject name description fields []
+  | otherwise =
+    throwError $ case description of
       Nothing -> "found duplicate fields in selection set: " <> duplicatesList
-    Just d -> "found duplicate fields in selection set for " <> toErrorMessage (unDescription d) <> ": " <> duplicatesList
+      Just (Description d) -> "found duplicate fields in selection set for " <> toErrorMessage d <> ": " <> duplicatesList
   where
     namesOrigins :: HashMap Name [Maybe origin]
     namesOrigins = M.fromListWith (<>) $ (dName &&& (pure . dOrigin)) . fDefinition <$> fields

server/src-lib/Hasura/GraphQL/Parser/Internal/Scalars.hs

@@ -24,6 +24,7 @@ where
 
 import Control.Monad ((>=>))
 import Data.Aeson qualified as A
+import Data.Aeson.Internal qualified as A.Internal
 import Data.Aeson.Types qualified as A
 import Data.Int (Int32, Int64)
 import Data.Scientific (Scientific)
@@ -33,9 +34,9 @@ import Data.Text qualified as Text
 import Data.Text.Read (decimal)
 import Data.UUID qualified as UUID
 import Hasura.Backends.Postgres.SQL.Value
-import Hasura.Base.Error
 import Hasura.Base.ErrorMessage (toErrorMessage)
 import Hasura.GraphQL.Parser.Class.Parse
+import Hasura.GraphQL.Parser.ErrorCode
 import Hasura.GraphQL.Parser.Internal.Convert
 import Hasura.GraphQL.Parser.Internal.TypeChecking
 import Hasura.GraphQL.Parser.Internal.Types
@@ -193,8 +194,7 @@ mkScalar name description parser =
   where
     schemaType = TNamed NonNullable $ Definition name description Nothing [] TIScalar
 
-convertWith ::
-  MonadParse m =>
-  (a -> A.Parser b) ->
-  (a -> m b)
-convertWith f x = either (parseErrorWith ParseFailed . toErrorMessage . qeError) pure $ runAesonParser f x
+convertWith :: MonadParse m => (a -> A.Parser b) -> a -> m b
+convertWith f x = case A.Internal.iparse f x of
+  A.Internal.IError path message -> withPath path $ parseErrorWith ParseFailed (toErrorMessage (Text.pack message))
+  A.Internal.ISuccess result -> pure result

server/src-lib/Hasura/GraphQL/Parser/Monad.hs

@@ -8,7 +8,6 @@ module Hasura.GraphQL.Parser.Monad
   )
 where
 
-import Control.Arrow ((<<<))
 import Control.Monad.Except
 import Control.Monad.Reader (MonadReader, ReaderT, mapReaderT)
 import Control.Monad.State.Strict (MonadState (..), StateT, evalStateT)
@@ -19,9 +18,9 @@ import Data.GADT.Compare.Extended
 import Data.IORef
 import Data.Kind qualified as K
 import Data.Proxy (Proxy (..))
-import Hasura.Base.Error
 import Hasura.Base.ErrorMessage
 import Hasura.GraphQL.Parser.Class
+import Hasura.GraphQL.Parser.ErrorCode
 import Language.Haskell.TH qualified as TH
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Type.Reflection (Typeable, typeRep, (:~:) (..))
@@ -173,11 +172,11 @@ newtype Parse a = Parse
   deriving (Functor, Applicative, Monad)
 
 runParse ::
-  MonadError QErr m =>
+  MonadError ParseError m =>
   Parse a ->
   m a
 runParse parse =
-  either reportParseErrors pure (runExcept <<< unParse $ parse)
+  either throwError pure . runExcept $ unParse parse
 
 instance MonadParse Parse where
   withKey key = Parse . withExceptT (\pe -> pe {pePath = key : pePath pe}) . unParse
@@ -187,12 +186,5 @@ instance MonadParse Parse where
 data ParseError = ParseError
   { pePath :: JSONPath,
     peMessage :: ErrorMessage,
-    peCode :: Code
+    peCode :: ParseErrorCode
   }
-
-reportParseErrors ::
-  MonadError QErr m =>
-  ParseError ->
-  m a
-reportParseErrors (ParseError {pePath, peMessage, peCode}) =
-  throwError (err400 peCode (fromErrorMessage peMessage)) {qePath = pePath}

server/src-lib/Hasura/GraphQL/Parser/Schema.hs

@@ -796,6 +796,16 @@ data ConflictingDefinitions origin
       (SomeDefinitionTypeInfo origin, TypeOriginStack)
       (SomeDefinitionTypeInfo origin, NonEmpty TypeOriginStack)
 
+instance ToErrorValue (ConflictingDefinitions origin) where
+  toErrorValue (ConflictingDefinitions (type1, origin1) (_type2, origins)) =
+    "Found conflicting definitions for "
+      <> toErrorValue (getName type1)
+      <> ".  The definition at "
+      <> toErrorValue origin1
+      <> " differs from the the definitions "
+      <> toErrorValue origins
+      <> "."
+
 -- | Although the majority of graphql-engine is written in terms of abstract
 -- mtl-style effect monads, we figured out that this particular codepath is
 -- quite hot, and that mtl has a measurable negative effect for accumulating

server/src-lib/Hasura/GraphQL/Schema.hs

@@ -12,12 +12,14 @@ import Control.Lens
 import Data.Aeson.Ordered qualified as JO
 import Data.Has
 import Data.HashMap.Strict qualified as Map
+import Data.HashMap.Strict.InsOrd qualified as OMap
 import Data.HashSet qualified as Set
 import Data.List.Extended (duplicates)
 import Data.Text.Extended
 import Data.Text.NonEmpty qualified as NT
 import Hasura.Base.Error
-import Hasura.Base.ErrorMessage (toErrorMessage)
+import Hasura.Base.ErrorMessage
+import Hasura.Base.ToErrorValue
 import Hasura.GraphQL.ApolloFederation
 import Hasura.GraphQL.Context
 import Hasura.GraphQL.Execute.Types
@@ -226,6 +228,7 @@ buildRoleContext options sources remotes allActionInfos customTypes role remoteS
     -- information in the case of the admin role.
     introspectionSchema <- do
       result <-
+        throwOnConflictingDefinitions $
           convertToSchemaIntrospection
             <$> buildIntrospectionSchema
               (P.parserType queryParserBackend)
@@ -241,7 +244,7 @@ buildRoleContext options sources remotes allActionInfos customTypes role remoteS
           then result
           else G.SchemaIntrospection mempty
 
-    void $
+    void . throwOnConflictingDefinitions $
       buildIntrospectionSchema
         (P.parserType queryParserFrontend)
         (P.parserType <$> mutationParserFrontend)
@@ -358,12 +361,12 @@ buildRelayRoleContext options sources allActionInfos customTypes role expFeature
     -- In order to catch errors early, we attempt to generate the data
     -- required for introspection, which ends up doing a few correctness
     -- checks in the GraphQL schema.
-    void $
+    void . throwOnConflictingDefinitions $
       buildIntrospectionSchema
         (P.parserType queryParserBackend)
         (P.parserType <$> mutationParserBackend)
         (P.parserType <$> subscriptionParser)
-    void $
+    void . throwOnConflictingDefinitions $
       buildIntrospectionSchema
         (P.parserType queryParserFrontend)
         (P.parserType <$> mutationParserFrontend)
@@ -481,14 +484,14 @@ unauthenticatedContext allRemotes remoteSchemaPermsCtx = do
           )
     mutationParser <-
       whenMaybe (not $ null mutationFields) $
-        P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFields
+        safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFields
           <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
     subscriptionParser <-
       whenMaybe (not $ null subscriptionFields) $
-        P.safeSelectionSet subscriptionRoot (Just $ G.Description "subscription root") subscriptionFields
+        safeSelectionSet subscriptionRoot (Just $ G.Description "subscription root") subscriptionFields
           <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
     queryParser <- queryWithIntrospectionHelper queryFields mutationParser Nothing
-    void $
+    void . throwOnConflictingDefinitions $
       buildIntrospectionSchema
         (P.parserType queryParser)
         (P.parserType <$> mutationParser)
@@ -735,13 +738,8 @@ parseBuildIntrospectionSchema ::
   Maybe (P.Type 'Output) ->
   Maybe (P.Type 'Output) ->
   m Schema
-parseBuildIntrospectionSchema q m s = qerrAsMonadParse $ buildIntrospectionSchema q m s
-  where
-    qerrAsMonadParse :: MonadParse m => Except QErr a -> m a
-    qerrAsMonadParse action =
-      case runExcept action of
-        Right a -> pure a
-        Left QErr {..} -> foldr P.withKey (P.parseErrorWith qeCode (toErrorMessage qeError)) qePath
+parseBuildIntrospectionSchema q m s =
+  buildIntrospectionSchema q m s `onLeft` (P.parseErrorWith P.ConflictingDefinitionsError . toErrorValue)
 
 queryWithIntrospectionHelper ::
   forall n m.
@@ -761,18 +759,16 @@ queryWithIntrospectionHelper basicQueryFP mutationP subscriptionP = do
       placeholderField = NotNamespaced (RFRaw $ JO.String placeholderText) <$ P.selection_ Name._no_queries_available (Just $ G.Description placeholderText) P.string
       fixedQueryFP = if null basicQueryFP then [placeholderField] else basicQueryFP
   basicQueryP <- queryRootFromFields fixedQueryFP
-  let buildIntrospectionResponse printResponseFromSchema = do
-        partialSchema <-
-          parseBuildIntrospectionSchema
+  let buildIntrospectionResponse printResponseFromSchema =
+        NotNamespaced . RFRaw . printResponseFromSchema
+          <$> parseBuildIntrospectionSchema
             (P.parserType basicQueryP)
             (P.parserType <$> mutationP)
             (P.parserType <$> subscriptionP)
-        pure $ NotNamespaced $ RFRaw $ printResponseFromSchema partialSchema
       introspection = [schema, typeIntrospection] <&> (`P.bindField` buildIntrospectionResponse)
       {-# INLINE introspection #-}
       partialQueryFields = fixedQueryFP ++ introspection
-  P.safeSelectionSet queryRoot Nothing partialQueryFields
-    <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
+  safeSelectionSet queryRoot Nothing partialQueryFields <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
 
 queryRootFromFields ::
   forall n m.
@@ -780,7 +776,7 @@ queryRootFromFields ::
   [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] ->
   m (Parser 'Output n (RootFieldMap (QueryRootField UnpreparedValue)))
 queryRootFromFields fps =
-  P.safeSelectionSet queryRoot Nothing fps <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
+  safeSelectionSet queryRoot Nothing fps <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
 
 -- | Prepare the parser for subscriptions. Every postgres query field is
 -- exposed as a subscription along with fields to get the status of
@@ -797,7 +793,7 @@ buildSubscriptionParser sourceSubscriptionFields allActions customTypes remoteSu
   actionSubscriptionFields <- fmap (fmap NotNamespaced) . concat <$> traverse (buildActionSubscriptionFields customTypes) allActions
   let subscriptionFields = sourceSubscriptionFields <> actionSubscriptionFields <> fmap (fmap $ fmap RFRemote) remoteSubscriptionFields
   whenMaybe (not $ null subscriptionFields) $
-    P.safeSelectionSet subscriptionRoot Nothing subscriptionFields
+    safeSelectionSet subscriptionRoot Nothing subscriptionFields
       <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
 
 buildMutationParser ::
@@ -815,12 +811,23 @@ buildMutationParser allRemotes allActions customTypes mutationFields = do
           <> (fmap NotNamespaced <$> actionParsers)
           <> (fmap (fmap RFRemote) <$> allRemotes)
   whenMaybe (not $ null mutationFieldsParser) $
-    P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFieldsParser
+    safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFieldsParser
       <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
 
 -------------------------------------------------------------------------------
 -- Local helpers
 
+-- | Calls 'P.safeSelectionSet', and rethrows any error as a 'QErr'.
+safeSelectionSet ::
+  forall n m a.
+  (QErrM n, MonadParse m) =>
+  G.Name ->
+  Maybe G.Description ->
+  [FieldParser m a] ->
+  n (Parser 'Output m (OMap.InsOrdHashMap G.Name (P.ParsedSelection a)))
+safeSelectionSet name description fields =
+  P.safeSelectionSet name description fields `onLeft` (throw500 . fromErrorMessage)
+
 -- | Apply a source's customization options to a list of its fields.
 customizeFields ::
   forall f n db remote action.
@@ -887,7 +894,10 @@ queryRoot :: G.Name
 queryRoot = Name._query_root
 
 finalizeParser :: Parser 'Output P.Parse a -> ParserFn a
-finalizeParser parser = P.runParse . P.runParser parser
+finalizeParser parser = P.toQErr . P.runParse . P.runParser parser
+
+throwOnConflictingDefinitions :: QErrM m => Either P.ConflictingDefinitions a -> m a
+throwOnConflictingDefinitions = either (throw500 . fromErrorMessage . toErrorValue) pure
 
 type ConcreteSchemaT m a =
   P.SchemaT

server/src-lib/Hasura/GraphQL/Schema/Action.hs

@@ -437,7 +437,7 @@ customScalarParser = \case
             -- well.
             void $
               parseScalarValue @b (unwrapScalar scalarType) jsonInput
-                `onLeft` \e -> parseErrorWith ParseFailed . toErrorMessage $ qeError e
+                `onLeft` \e -> parseErrorWith P.ParseFailed . toErrorMessage $ qeError e
             pure jsonInput
      in P.Parser
           { pType = schemaType,

server/src-lib/Hasura/GraphQL/Schema/Introspect.hs

@@ -13,9 +13,6 @@ import Data.HashMap.Strict.InsOrd qualified as OMap
 import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
 import Data.Vector qualified as V
-import Hasura.Base.Error
-import Hasura.Base.ErrorMessage
-import Hasura.Base.ToErrorValue
 import Hasura.GraphQL.Parser.Class
 import Hasura.GraphQL.Parser.Directives
 import Hasura.GraphQL.Parser.Name qualified as GName
@@ -196,11 +193,10 @@ query_root obtained in (B). -}
 --
 -- See Note [What introspection exposes]
 buildIntrospectionSchema ::
-  MonadError QErr m =>
   P.Type 'Output ->
   Maybe (P.Type 'Output) ->
   Maybe (P.Type 'Output) ->
-  m P.Schema
+  Either P.ConflictingDefinitions P.Schema
 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
@@ -212,7 +208,7 @@ buildIntrospectionSchema queryRoot' mutationRoot' subscriptionRoot' = do
 
   -- Collect type information of all non-introspection fields
   allBasicTypes <-
-    collectTypes
+    P.collectTypeDefinitions
       [ P.TypeDefinitionsWrapper queryRoot',
         P.TypeDefinitionsWrapper mutationRoot',
         P.TypeDefinitionsWrapper subscriptionRoot',
@@ -224,7 +220,7 @@ buildIntrospectionSchema queryRoot' mutationRoot' subscriptionRoot' = do
   -- the types here are always the same and specified by the GraphQL spec
 
   -- Pull all the introspection types out (__Type, __Schema, etc)
-  allIntrospectionTypes <- collectTypes (map fDefinition introspection)
+  allIntrospectionTypes <- P.collectTypeDefinitions (map fDefinition introspection)
 
   let allTypes =
         Map.unions
@@ -241,23 +237,6 @@ buildIntrospectionSchema queryRoot' mutationRoot' subscriptionRoot' = do
         sDirectives = directives
       }
 
-collectTypes ::
-  (MonadError QErr m, P.HasTypeDefinitions a) =>
-  a ->
-  m (HashMap G.Name P.SomeDefinitionTypeInfo)
-collectTypes x =
-  P.collectTypeDefinitions x
-    `onLeft` \(P.ConflictingDefinitions (type1, origin1) (_type2, origins)) ->
-      -- See Note [Collecting types from the GraphQL schema]
-      throw500 . fromErrorMessage $
-        "Found conflicting definitions for "
-          <> toErrorValue (P.getName type1)
-          <> ".  The definition at "
-          <> toErrorValue origin1
-          <> " differs from the the definitions "
-          <> toErrorValue origins
-          <> "."
-
 -- | Generate a __type introspection parser
 typeIntrospection ::
   forall n.

server/src-lib/Hasura/GraphQL/Schema/Parser.hs

@@ -35,6 +35,8 @@ module Hasura.GraphQL.Schema.Parser
     pattern P.Parser,
     Schema,
     pattern P.Schema,
+    ConflictingDefinitions,
+    pattern P.ConflictingDefinitions,
     Definition,
     pattern P.Definition,
     Type,
@@ -51,14 +53,21 @@ module Hasura.GraphQL.Schema.Parser
     pattern P.SomeDefinitionTypeInfo,
     TypeDefinitionsWrapper,
     pattern TypeDefinitionsWrapper,
+    P.ParseErrorCode (..),
+    toQErr,
     module Hasura.GraphQL.Parser,
   )
 where
 
 -- Re-export everything, except types whose type parameter we want to fill in in
 -- this module.
+
+import Control.Monad.Error.Class
+import Hasura.Base.Error
+import Hasura.Base.ErrorMessage (ErrorMessage (fromErrorMessage))
 import Hasura.GraphQL.Parser hiding
-  ( Definition,
+  ( ConflictingDefinitions (..),
+    Definition,
     Directive,
     DirectiveInfo,
     FieldInfo,
@@ -66,6 +75,7 @@ import Hasura.GraphQL.Parser hiding
     HasTypeDefinitions,
     InputFieldInfo,
     InputFieldsParser,
+    ParseErrorCode (..),
     Parser,
     Schema,
     SomeDefinitionTypeInfo,
@@ -73,6 +83,7 @@ import Hasura.GraphQL.Parser hiding
     TypeDefinitionsWrapper,
   )
 import Hasura.GraphQL.Parser qualified as P
+import Hasura.Prelude
 import Hasura.RQL.Types.Metadata.Object
 
 type FieldParser = P.FieldParser MetadataObjId
@@ -81,6 +92,8 @@ type Parser = P.Parser MetadataObjId
 
 type Schema = P.Schema MetadataObjId
 
+type ConflictingDefinitions = P.ConflictingDefinitions MetadataObjId
+
 type Type = P.Type MetadataObjId
 
 type InputFieldsParser = P.InputFieldsParser MetadataObjId
@@ -106,3 +119,16 @@ type TypeDefinitionsWrapper = P.TypeDefinitionsWrapper MetadataObjId
 -- 'MetadataObjId' set for its origin type parameter.
 pattern TypeDefinitionsWrapper :: () => forall a. HasTypeDefinitions a => a -> TypeDefinitionsWrapper
 pattern TypeDefinitionsWrapper typeDef = P.TypeDefinitionsWrapper typeDef
+
+toQErr :: (MonadError QErr m) => Either ParseError a -> m a
+toQErr = either (throwError . parseErrorToQErr) pure
+  where
+    parseErrorToQErr :: ParseError -> QErr
+    parseErrorToQErr ParseError {pePath, peMessage, peCode} =
+      (err400 (parseErrorCodeToCode peCode) (fromErrorMessage peMessage)) {qePath = pePath}
+
+    parseErrorCodeToCode :: P.ParseErrorCode -> Code
+    parseErrorCodeToCode P.ValidationFailed = ValidationFailed
+    parseErrorCodeToCode P.ParseFailed = ParseFailed
+    parseErrorCodeToCode P.ConflictingDefinitionsError = Unexpected
+    parseErrorCodeToCode P.NotSupported = NotSupported

server/src-lib/Hasura/GraphQL/Schema/Relay.hs

@@ -220,7 +220,7 @@ nodeField sourceCache = do
         let columnType = ciType columnInfo
         parsedValue <-
           parseScalarValueColumnType columnType columnValue `onLeft` \e ->
-            P.parseErrorWith ParseFailed $ "value of column " <> toErrorValue (ciColumn columnInfo) <> " in node id: " <> toErrorMessage (qeError e)
+            P.parseErrorWith P.ParseFailed $ "value of column " <> toErrorValue (ciColumn columnInfo) <> " in node id: " <> toErrorMessage (qeError e)
         pure $
           IR.BoolField $
             IR.AVColumn

server/src-test/Hasura/Base/Error/TestInstances.hs

@@ -6,6 +6,6 @@ import Data.Text qualified as Text
 import Hasura.Base.Error
 import Hasura.Prelude
 
--- Orphan instance so that we can write assertions over `Either QErr a`.
+-- Orphan instance so that we can write assertions over 'Either QErr a'.
 instance Show QErr where
   show = Text.unpack . showQErr

server/src-test/Hasura/GraphQL/Parser/MonadParseTest.hs

@@ -1,15 +1,15 @@
 module Hasura.GraphQL.Parser.MonadParseTest (spec) where
 
 import Data.Aeson.Internal
-import Hasura.Base.Error
-import Hasura.Base.Error.TestInstances ()
 import Hasura.Base.ErrorMessage
 import Hasura.GraphQL.Parser.Class.Parse
+import Hasura.GraphQL.Parser.ErrorCode
 import Hasura.GraphQL.Parser.Monad
+import Hasura.GraphQL.Parser.TestInstances ()
 import Hasura.Prelude
 import Test.Hspec
 
-runParse' :: Parse () -> Either QErr ()
+runParse' :: Parse () -> Either ParseError ()
 runParse' = runParse @_ @()
 
 errorMessage :: ErrorMessage
@@ -17,13 +17,19 @@ errorMessage = "oh no"
 
 spec :: Spec
 spec = do
-  describe "withKey" $ do
-    it "Path is empty when no keys added" $ do
+  describe "parse error path" $ do
+    it "is empty when no keys added" $ do
       let parser = parseError errorMessage
-          expected = (err400 ValidationFailed (fromErrorMessage errorMessage)) {qePath = mempty}
+          expected = ParseError {pePath = [], peMessage = errorMessage, peCode = ValidationFailed}
       runParse' parser `shouldBe` Left expected
 
-    it "Path has two items in the order they were added" $ do
+    it "has two items in the order they were added" $ do
       let parser = withKey (Key "dog") (withKey (Key "log") (parseError errorMessage))
-          expected = (err400 ValidationFailed (fromErrorMessage errorMessage)) {qePath = [Key "dog", Key "log"]}
+          expected = ParseError {pePath = [Key "dog", Key "log"], peMessage = errorMessage, peCode = ValidationFailed}
+      runParse' parser `shouldBe` Left expected
+
+    it "has multiple keys provisioned from a JSONPath" $ do
+      let path :: JSONPath = [Key "hi", Index 1, Key "foo bar"]
+          parser = withPath path (withKey (Key "first") (parseError errorMessage))
+          expected = ParseError {pePath = Key "first" : path, peMessage = errorMessage, peCode = ValidationFailed}
       runParse' parser `shouldBe` Left expected

server/src-test/Hasura/GraphQL/Parser/TestInstances.hs

@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Hasura.GraphQL.Parser.TestInstances () where
+
+import Hasura.Base.ErrorMessage (fromErrorMessage)
+import Hasura.GraphQL.Parser.Monad (ParseError (..))
+import Hasura.Prelude
+
+-- Orphan instances so that we can write assertions over 'Either ParseError a'.
+deriving stock instance Eq ParseError
+
+-- This cannot be automatically derived because 'ErrorMessage' doesn't have a 'Show' instance.
+instance Show ParseError where
+  show ParseError {pePath, peMessage, peCode} =
+    "ParseError { pePath = " <> show pePath <> ", peMessage = " <> show (fromErrorMessage peMessage) <> ", peCode = " <> show peCode <> "}"

server/src-test/Test/Parser/Monad.hs

@@ -14,9 +14,10 @@ where
 import Data.Aeson.Internal (JSONPathElement)
 import Data.Has (Has (..))
 import Data.Text qualified as T
-import Hasura.Base.Error (Code, QErr)
+import Hasura.Base.Error (QErr)
 import Hasura.Base.ErrorMessage
 import Hasura.GraphQL.Parser.Class (MonadParse (..), MonadSchema (..))
+import Hasura.GraphQL.Parser.ErrorCode
 import Hasura.GraphQL.Schema.Common (SchemaContext (..), SchemaKind (..), ignoreRemoteRelationship)
 import Hasura.GraphQL.Schema.NamingCase
 import Hasura.GraphQL.Schema.Options (SchemaOptions (..))
@@ -145,6 +146,6 @@ instance MonadParse ParserTestT where
   withKey :: JSONPathElement -> ParserTestT a -> ParserTestT a
   withKey = const id
 
-  parseErrorWith :: Code -> ErrorMessage -> ParserTestT a
+  parseErrorWith :: ParseErrorCode -> ErrorMessage -> ParserTestT a
   parseErrorWith code text =
     ParserTestT . Left . expectationFailure $ show code <> ": " <> T.unpack (fromErrorMessage text)