From f01c7f4ee6d866b30a1a43a25b3c5401a3f4a5aa Mon Sep 17 00:00:00 2001 From: Samir Talwar Date: Wed, 27 Jul 2022 14:24:50 +0200 Subject: [PATCH] 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 | 2 + .../Backends/BigQuery/Instances/Schema.hs | 2 +- .../Hasura/Backends/MSSQL/Instances/Schema.hs | 2 +- .../Hasura/Backends/MySQL/Instances/Schema.hs | 2 +- .../Backends/Postgres/Instances/Schema.hs | 2 +- .../Hasura/Backends/Postgres/Schema/Select.hs | 7 +- server/src-lib/Hasura/GraphQL/Execute.hs | 5 +- .../Hasura/GraphQL/Execute/Mutation.hs | 6 +- .../src-lib/Hasura/GraphQL/Execute/Query.hs | 6 +- server/src-lib/Hasura/GraphQL/Parser.hs | 2 + server/src-lib/Hasura/GraphQL/Parser/Class.hs | 1 + .../Hasura/GraphQL/Parser/Class/Parse.hs | 13 ++-- .../Hasura/GraphQL/Parser/ErrorCode.hs | 10 +++ .../Hasura/GraphQL/Parser/Internal/Parser.hs | 16 ++--- .../Hasura/GraphQL/Parser/Internal/Scalars.hs | 12 ++-- server/src-lib/Hasura/GraphQL/Parser/Monad.hs | 16 ++--- .../src-lib/Hasura/GraphQL/Parser/Schema.hs | 10 +++ server/src-lib/Hasura/GraphQL/Schema.hs | 68 +++++++++++-------- .../src-lib/Hasura/GraphQL/Schema/Action.hs | 2 +- .../Hasura/GraphQL/Schema/Introspect.hs | 27 +------- .../src-lib/Hasura/GraphQL/Schema/Parser.hs | 28 +++++++- server/src-lib/Hasura/GraphQL/Schema/Relay.hs | 2 +- .../Hasura/Base/Error/TestInstances.hs | 2 +- .../Hasura/GraphQL/Parser/MonadParseTest.hs | 22 +++--- .../Hasura/GraphQL/Parser/TestInstances.hs | 15 ++++ server/src-test/Test/Parser/Monad.hs | 5 +- 26 files changed, 169 insertions(+), 116 deletions(-) create mode 100644 server/src-lib/Hasura/GraphQL/Parser/ErrorCode.hs create mode 100644 server/src-test/Hasura/GraphQL/Parser/TestInstances.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 92b7f87003f..c1073930d4d 100644 --- a/server/graphql-engine.cabal +++ b/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 diff --git a/server/src-lib/Hasura/Backends/BigQuery/Instances/Schema.hs b/server/src-lib/Hasura/Backends/BigQuery/Instances/Schema.hs index 96696d908ee..3cdab3b2e68 100644 --- a/server/src-lib/Hasura/Backends/BigQuery/Instances/Schema.hs +++ b/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 = diff --git a/server/src-lib/Hasura/Backends/MSSQL/Instances/Schema.hs b/server/src-lib/Hasura/Backends/MSSQL/Instances/Schema.hs index eb6e57fd962..f7e596ca3a5 100644 --- a/server/src-lib/Hasura/Backends/MSSQL/Instances/Schema.hs +++ b/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 diff --git a/server/src-lib/Hasura/Backends/MySQL/Instances/Schema.hs b/server/src-lib/Hasura/Backends/MySQL/Instances/Schema.hs index 801e23cb72a..f5bdee75e67 100644 --- a/server/src-lib/Hasura/Backends/MySQL/Instances/Schema.hs +++ b/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 diff --git a/server/src-lib/Hasura/Backends/Postgres/Instances/Schema.hs b/server/src-lib/Hasura/Backends/Postgres/Instances/Schema.hs index dc6a08d336f..80150171ab6 100644 --- a/server/src-lib/Hasura/Backends/Postgres/Instances/Schema.hs +++ b/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 diff --git a/server/src-lib/Hasura/Backends/Postgres/Schema/Select.hs b/server/src-lib/Hasura/Backends/Postgres/Schema/Select.hs index 283a13c21d6..8b87d7fa0ad 100644 --- a/server/src-lib/Hasura/Backends/Postgres/Schema/Select.hs +++ b/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. diff --git a/server/src-lib/Hasura/GraphQL/Execute.hs b/server/src-lib/Hasura/GraphQL/Execute.hs index 05661b7b1a7..25f25081eeb 100644 --- a/server/src-lib/Hasura/GraphQL/Execute.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs index 1eaf5f2c997..9f7bf887bbc 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Execute/Query.hs b/server/src-lib/Hasura/GraphQL/Execute/Query.hs index 87d0eb5e71d..cc6e8545db8 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Query.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Parser.hs b/server/src-lib/Hasura/GraphQL/Parser.hs index 5c982cf1fc3..91aa5a59ea0 100644 --- a/server/src-lib/Hasura/GraphQL/Parser.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Parser/Class.hs b/server/src-lib/Hasura/GraphQL/Parser/Class.hs index d079e17cc23..fd5c0fe6df9 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Class.hs +++ b/server/src-lib/Hasura/GraphQL/Parser/Class.hs @@ -3,6 +3,7 @@ module Hasura.GraphQL.Parser.Class ( MonadSchema (..), memoize, MonadParse (..), + withPath, parseError, ) where diff --git a/server/src-lib/Hasura/GraphQL/Parser/Class/Parse.hs b/server/src-lib/Hasura/GraphQL/Parser/Class/Parse.hs index 0658162b68e..51caeea8904 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Class/Parse.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Parser/ErrorCode.hs b/server/src-lib/Hasura/GraphQL/Parser/ErrorCode.hs new file mode 100644 index 00000000000..aaab3d9664f --- /dev/null +++ b/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) diff --git a/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs b/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs index 46d39e3b0a0..0772d32a9e8 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs +++ b/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 - Nothing -> "found duplicate fields in selection set: " <> duplicatesList - Just d -> "found duplicate fields in selection set for " <> toErrorMessage (unDescription d) <> ": " <> duplicatesList +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 (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 diff --git a/server/src-lib/Hasura/GraphQL/Parser/Internal/Scalars.hs b/server/src-lib/Hasura/GraphQL/Parser/Internal/Scalars.hs index f4a1b22fd72..37f51d90265 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Internal/Scalars.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Parser/Monad.hs b/server/src-lib/Hasura/GraphQL/Parser/Monad.hs index 0df39f7919f..3c4fc613c30 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Monad.hs +++ b/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} diff --git a/server/src-lib/Hasura/GraphQL/Parser/Schema.hs b/server/src-lib/Hasura/GraphQL/Parser/Schema.hs index 8bc44136994..2102998e3cc 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Schema.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index dace309b6f2..c951cf4c285 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/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,11 +228,12 @@ buildRoleContext options sources remotes allActionInfos customTypes role remoteS -- information in the case of the admin role. introspectionSchema <- do result <- - convertToSchemaIntrospection - <$> buildIntrospectionSchema - (P.parserType queryParserBackend) - (P.parserType <$> mutationParserBackend) - (P.parserType <$> subscriptionParser) + throwOnConflictingDefinitions $ + convertToSchemaIntrospection + <$> buildIntrospectionSchema + (P.parserType queryParserBackend) + (P.parserType <$> mutationParserBackend) + (P.parserType <$> subscriptionParser) pure $ -- We don't need to persist the introspection schema for all the roles here. -- TODO(nicuveo): we treat the admin role differently in this function, @@ -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 diff --git a/server/src-lib/Hasura/GraphQL/Schema/Action.hs b/server/src-lib/Hasura/GraphQL/Schema/Action.hs index 2c886c34400..e6c2d93599d 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Action.hs +++ b/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, diff --git a/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs b/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs index 1ead6cd9f19..92499bca622 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs +++ b/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. diff --git a/server/src-lib/Hasura/GraphQL/Schema/Parser.hs b/server/src-lib/Hasura/GraphQL/Schema/Parser.hs index 8cbeb6b38a7..46e3e8aa5d6 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Parser.hs +++ b/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 diff --git a/server/src-lib/Hasura/GraphQL/Schema/Relay.hs b/server/src-lib/Hasura/GraphQL/Schema/Relay.hs index ecffb45bc39..20b1b3946e0 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Relay.hs +++ b/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 diff --git a/server/src-test/Hasura/Base/Error/TestInstances.hs b/server/src-test/Hasura/Base/Error/TestInstances.hs index faffa71a2f0..ad42df311ba 100644 --- a/server/src-test/Hasura/Base/Error/TestInstances.hs +++ b/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 diff --git a/server/src-test/Hasura/GraphQL/Parser/MonadParseTest.hs b/server/src-test/Hasura/GraphQL/Parser/MonadParseTest.hs index 244b73877ab..ce922164db7 100644 --- a/server/src-test/Hasura/GraphQL/Parser/MonadParseTest.hs +++ b/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 diff --git a/server/src-test/Hasura/GraphQL/Parser/TestInstances.hs b/server/src-test/Hasura/GraphQL/Parser/TestInstances.hs new file mode 100644 index 00000000000..6efb0305c3a --- /dev/null +++ b/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 <> "}" diff --git a/server/src-test/Test/Parser/Monad.hs b/server/src-test/Test/Parser/Monad.hs index e3801cd0bb8..e4a2548aa2a 100644 --- a/server/src-test/Test/Parser/Monad.hs +++ b/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)