server: refactor for faster introspection queries

by bypassing intermediate aeson Values. There were a couple places where
this didn't work out, and so we need to carry around some extra
information. This is significant for UX as e.g. the console runs
introspection frequently.

Note that e.g. regular postgres graphql queries return json directly from the
DB so this work isn't relevant there.

GitOrigin-RevId: 2d7d373766ee5b60ba5e46b76ff01ac7d4602475

Author: jberryman

server/src-lib/Hasura/App.hs

@@ -127,6 +127,7 @@ import Hasura.RQL.DDL.Schema.Cache.Common
 import Hasura.RQL.DDL.Schema.Cache.Config
 import Hasura.RQL.DDL.Schema.Catalog
 import Hasura.RQL.DDL.SchemaRegistry qualified as SchemaRegistry
+import Hasura.RQL.IR.Root (irEncJSON)
 import Hasura.RQL.Types.Allowlist
 import Hasura.RQL.Types.Backend
 import Hasura.RQL.Types.BackendType
@@ -771,8 +772,8 @@ instance MonadGQLExecutionCheck AppM where
     checkQueryInAllowlist enableAL AllowlistModeGlobalOnly userInfo req sc
     return req
 
-  executeIntrospection _ introspectionQuery _ =
-    pure $ Right $ ExecStepRaw introspectionQuery
+  executeIntrospection _ introspectionResult _ =
+    pure $ Right $ ExecStepRaw (irEncJSON introspectionResult)
 
   checkGQLBatchedReqs _ _ _ _ = runExceptT $ pure ()
 

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

@@ -21,6 +21,7 @@ import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
 import Data.Text qualified as T
 import Hasura.Base.Error
 import Hasura.Base.ErrorMessage (toErrorMessage)
+import Hasura.EncJSON
 import Hasura.GraphQL.Parser qualified as P
 import Hasura.GraphQL.Schema.Common
 import Hasura.GraphQL.Schema.Parser
@@ -165,7 +166,12 @@ mkServiceField = serviceFieldParser
     serviceFieldParser =
       P.subselection_ Name.__service Nothing serviceParser `bindField` \selSet -> do
         let partialValue = InsOrdHashMap.map (\ps -> handleTypename (\tName _ -> JO.toOrdered tName) ps) (InsOrdHashMap.mapKeys G.unName selSet)
-        pure \schemaIntrospection -> RFRaw . JO.fromOrderedHashMap $ (partialValue ?? schemaIntrospection)
+        pure \schemaIntrospection ->
+          RFRaw
+            . SchemaIntrospection
+            $ encJFromAssocList
+            $ map (fmap encJFromOrderedValue)
+            $ InsOrdHashMap.toList (partialValue ?? schemaIntrospection)
 
 apolloRootFields ::
   ApolloFederationStatus ->

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

@@ -30,6 +30,9 @@ instance (J.ToJSON a) => J.ToJSON (RoleContext a) where
 
 data GQLContext = GQLContext
   { gqlQueryParser :: ParserFn (RootFieldMap (IR.QueryRootField IR.UnpreparedValue)),
+    -- | Names of top-level query root fields (used for conflict detection without
+    -- needing to run/decode an introspection query)
+    gqlQueryRootFieldNames :: [G.Name],
     gqlMutationParser :: Maybe (ParserFn (RootFieldMap (IR.MutationRootField IR.UnpreparedValue))),
     gqlSubscriptionParser :: Maybe (ParserFn (RootFieldMap (IR.QueryRootField IR.UnpreparedValue)))
   }

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

@@ -245,7 +245,7 @@ buildSubscriptionPlan removeEmptySubscriptionResponses userInfo rootFields param
               case JO.asObject oldResponse of
                 Left (_err :: String) -> oldResponse
                 Right responseObj ->
-                  JO.Object $ JO.insert (fieldIndex, G.unName $ _rfaAlias gName) val responseObj
+                  JO.Object $ JO.insert (fieldIndex, G.unName $ _rfaAlias gName) (JO.toOrdered (IR.irEncJSON val)) responseObj
         pure ((accLiveQueryFields, accStreamingFields), Just (Endo newModifier) <> modifier)
       IR.RFMulti _ -> throw400 NotSupported "not supported over subscriptions"
       IR.RFDB src e -> do

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

@@ -14,7 +14,6 @@ where
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson qualified as J
 import Data.Aeson.Casing qualified as J
-import Data.Aeson.Ordered qualified as JO
 import Data.Environment qualified as Env
 import Data.Kind (Type)
 import Data.Text.Extended
@@ -333,7 +332,7 @@ data ExecutionStep where
     ExecutionStep
   -- | Output a plain JSON object
   ExecStepRaw ::
-    JO.Value ->
+    EncJSON ->
     ExecutionStep
   ExecStepMulti ::
     [ExecutionStep] ->

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

@@ -3,12 +3,12 @@ module Hasura.GraphQL.Execute.Common
   )
 where
 
-import Data.Aeson.Ordered qualified as JO
 import Hasura.Authentication.User (UserInfo)
 import Hasura.Base.Error
 import Hasura.GraphQL.Execute.Backend
 import Hasura.GraphQL.Transport.HTTP.Protocol
 import Hasura.Prelude
+import Hasura.RQL.IR.Root (RFRawPayload)
 import Hasura.RQL.Types.GraphqlSchemaIntrospection
 import Hasura.RQL.Types.SchemaCache
 import Hasura.Server.Init (AllowListStatus)
@@ -43,7 +43,7 @@ class (Monad m) => MonadGQLExecutionCheck m where
 
   executeIntrospection ::
     UserInfo ->
-    JO.Value ->
+    RFRawPayload ->
     SetGraphqlIntrospectionOptions ->
     m (Either QErr ExecutionStep)
 

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

@@ -11,7 +11,6 @@ import Control.Concurrent.Extended (concurrentlyEIO, forConcurrentlyEIO)
 import Control.Concurrent.STM qualified as STM
 import Control.Lens hiding (contexts)
 import Control.Monad.Memoize
-import Data.Aeson.Ordered qualified as JO
 import Data.HashMap.Strict qualified as HashMap
 import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
 import Data.HashSet qualified as Set
@@ -23,6 +22,7 @@ import Hasura.Authentication.Role (RoleName, adminRoleName, mkRoleNameSafe)
 import Hasura.Base.Error
 import Hasura.Base.ErrorMessage
 import Hasura.Base.ToErrorValue
+import Hasura.EncJSON
 import Hasura.Function.Cache
 import Hasura.GraphQL.ApolloFederation
 import Hasura.GraphQL.Context
@@ -394,15 +394,20 @@ buildRoleContext sampledFeatureFlags options sources remotes actions customTypes
         (P.parserType <$> mutationParserFrontend)
         (P.parserType <$> subscriptionParser)
 
+    let queryRootFieldNamesFrontend = queryRootFieldNamesOf queryParserFrontend
+        queryRootFieldNamesBackend = queryRootFieldNamesOf queryParserBackend
+
     -- (since we're running this in parallel in caller, be strict)
     let !frontendContext =
           GQLContext
             (finalizeParser queryParserFrontend)
+            queryRootFieldNamesFrontend
             (finalizeParser <$> mutationParserFrontend)
             (finalizeParser <$> subscriptionParser)
         !backendContext =
           GQLContext
             (finalizeParser queryParserBackend)
+            queryRootFieldNamesBackend
             (finalizeParser <$> mutationParserBackend)
             (finalizeParser <$> subscriptionParser)
 
@@ -527,14 +532,18 @@ buildRelayRoleContext options sources actions customTypes role expFeatures schem
         (P.parserType <$> mutationParserFrontend)
         (P.parserType <$> subscriptionParser)
 
-    let frontendContext =
+    let relayFrontendFieldNames = queryRootFieldNamesOf queryParserFrontend
+        relayBackendFieldNames = queryRootFieldNamesOf queryParserBackend
+        frontendContext =
           GQLContext
             (finalizeParser queryParserFrontend)
+            relayFrontendFieldNames
             (finalizeParser <$> mutationParserFrontend)
             (finalizeParser <$> subscriptionParser)
         backendContext =
           GQLContext
             (finalizeParser queryParserBackend)
+            relayBackendFieldNames
             (finalizeParser <$> mutationParserBackend)
             (finalizeParser <$> subscriptionParser)
 
@@ -653,7 +662,8 @@ unauthenticatedContext options sources allRemotes expFeatures schemaSampledFeatu
         (P.parserType queryParser)
         (P.parserType <$> mutationParser)
         (P.parserType <$> subscriptionParser)
-    pure (GQLContext (finalizeParser queryParser) (finalizeParser <$> mutationParser) (finalizeParser <$> subscriptionParser), remoteErrors)
+    let unauthFieldNames = queryRootFieldNamesOf queryParser
+    pure (GQLContext (finalizeParser queryParser) unauthFieldNames (finalizeParser <$> mutationParser) (finalizeParser <$> subscriptionParser), remoteErrors)
 
 -------------------------------------------------------------------------------
 -- Building parser fields
@@ -1024,13 +1034,14 @@ queryWithIntrospectionHelper basicQueryFP mutationP subscriptionP = do
       -- Those two requirements cannot both be met when a service is mutations-only, and does not
       -- provide any query. In such a case, to meet both of those, we introduce a placeholder query
       -- in the schema.
-      placeholderText = "There are no queries available to the current role. Either there are no sources or remote schemas configured, or the current role doesn't have the required permissions."
-      placeholderField = NotNamespaced (RFRaw $ JO.String placeholderText) <$ P.selection_ Name._no_queries_available (Just $ G.Description placeholderText) P.string
+      placeholderText = "There are no queries available to the current role. Either there are no sources or remote schemas configured, or the current role doesn't have the required permissions." :: Text
+      placeholderField = NotNamespaced (RFRaw . TypenameResult $ encJFromJValue 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 =
         NotNamespaced
           . RFRaw
+          . SchemaIntrospection
           . printResponseFromSchema
           <$> parseBuildIntrospectionSchema
             (P.parserType basicQueryP)
@@ -1104,8 +1115,8 @@ customizeFields ::
   (Functor f, MonadParse n) =>
   ResolvedSourceCustomization ->
   MkTypename ->
-  f [FieldParser n (RootField db remote action JO.Value)] ->
-  f [FieldParser n (NamespacedField (RootField db remote action JO.Value))]
+  f [FieldParser n (RootField db remote action RFRawPayload)] ->
+  f [FieldParser n (NamespacedField (RootField db remote action RFRawPayload))]
 customizeFields ResolvedSourceCustomization {..} =
   fmap . customizeNamespace _rscRootNamespace (const typenameToRawRF)
 
@@ -1166,15 +1177,24 @@ queryRoot = Name._query_root
 finalizeParser :: Parser 'Output P.Parse a -> ParserFn a
 finalizeParser parser = P.toQErr . P.runParse . P.runParser parser
 
+-- | Extract the top-level field names from a query root parser's output type,
+-- for storage in 'GQLContext' and use in conflict detection ('checkConflictingNode').
+-- Returns @[]@ if the type isn't a named object, which shouldn't happen for a
+-- well-formed query root but is handled gracefully.
+queryRootFieldNamesOf :: P.Parser 'Output n a -> [G.Name]
+queryRootFieldNamesOf p = case P.parserType p of
+  P.TNamed _ (P.Definition _ _ _ _ (P.TIObject oi)) -> map P.dName (P.oiFields oi)
+  _ -> []
+
 throwOnConflictingDefinitions :: (QErrM m) => Either P.ConflictingDefinitions a -> m a
 throwOnConflictingDefinitions = either (throw500 . fromErrorMessage . toErrorValue) pure
 
 typenameToNamespacedRawRF ::
-  P.ParsedSelection (NamespacedField (RootField db remote action JO.Value)) ->
-  NamespacedField (RootField db remote action JO.Value)
-typenameToNamespacedRawRF = P.handleTypename $ NotNamespaced . RFRaw . JO.String . toTxt
+  P.ParsedSelection (NamespacedField (RootField db remote action RFRawPayload)) ->
+  NamespacedField (RootField db remote action RFRawPayload)
+typenameToNamespacedRawRF = P.handleTypename $ NotNamespaced . RFRaw . TypenameResult . encJFromJValue . toTxt
 
 typenameToRawRF ::
-  P.ParsedSelection (RootField db remote action JO.Value) ->
-  RootField db remote action JO.Value
-typenameToRawRF = P.handleTypename $ RFRaw . JO.String . toTxt
+  P.ParsedSelection (RootField db remote action RFRawPayload) ->
+  RootField db remote action RFRawPayload
+typenameToRawRF = P.handleTypename $ RFRaw . TypenameResult . encJFromJValue . toTxt