Remove MonadTableInfo and MonadRole.

### Description

This PR moves Hasura-specific schema functions from `Hasura.GraphQL.Parser.Class` into `Hasura.GraphQL.Schema.Common`. It also removes the two corresponding monad aliases, and consequently harmonizes several parts of the code to use the same common constraint.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3947
GitOrigin-RevId: 40985a7d86da97a311bd480f9a57cc18c350c2a8

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

@@ -13,7 +13,6 @@ module Hasura.Backends.MSSQL.Schema.IfMatched
   )
 where
 
-import Data.Has
 import Data.Text.Extended
 import Hasura.Backends.MSSQL.Types.Insert
 import Hasura.Backends.MSSQL.Types.Internal (ScalarType (..))
@@ -59,7 +58,7 @@ ifMatchedFieldParser sourceName tableInfo = do
 -- | Parse a @tablename_if_matched@ object.
 ifMatchedObjectParser ::
   forall r m n.
-  (MonadBuildSchema 'MSSQL r m n) =>
+  MonadBuildSchema 'MSSQL r m n =>
   SourceName ->
   TableInfo 'MSSQL ->
   m (Maybe (Parser 'Input n (IfMatched (UnpreparedValue 'MSSQL))))
@@ -101,8 +100,8 @@ ifMatchedObjectParser sourceName tableInfo = runMaybeT do
 -- Return Nothing if there's no column the current user has "select"
 -- permissions for.
 tableInsertMatchColumnsEnum ::
-  forall m n r.
+  forall r m n.
-  (MonadSchema n m, MonadRole r m, MonadTableInfo r m, Has P.MkTypename r) =>
+  MonadBuildSchemaBase r m n =>
   SourceName ->
   TableInfo 'MSSQL ->
   m (Maybe (Parser 'Both n (Column 'MSSQL)))

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

@@ -1,24 +1,16 @@
 -- | Classes for monads used during schema construction and query parsing.
 module Hasura.GraphQL.Parser.Class
-  ( MonadParse (..),
+  ( MonadSchema (..),
+    memoize,
+    MonadParse (..),
     parseError,
-    module Hasura.GraphQL.Parser.Class,
   )
 where
 
-import Data.Has
-import Data.HashMap.Strict qualified as Map
-import Data.Text.Extended
 import GHC.Stack (HasCallStack)
-import Hasura.Base.Error
 import Hasura.GraphQL.Parser.Class.Parse
 import Hasura.GraphQL.Parser.Internal.Types
 import Hasura.Prelude
-import Hasura.RQL.Types.Backend
-import Hasura.RQL.Types.Common
-import Hasura.RQL.Types.Source
-import Hasura.RQL.Types.Table
-import Hasura.Session (RoleName)
 import Language.Haskell.TH qualified as TH
 import Type.Reflection (Typeable)
 
@@ -113,34 +105,6 @@ class (Monad m, MonadParse n) => MonadSchema n m | m -> n where
     m (p n b) ->
     m (p n b)
 
-type MonadRole r m = (MonadReader r m, Has RoleName r)
-
--- | Gets the current role the schema is being built for.
-askRoleName ::
-  MonadRole r m =>
-  m RoleName
-askRoleName = asks getter
-
-type MonadTableInfo r m = (MonadReader r m, Has SourceCache r, MonadError QErr m)
-
--- | Looks up table information for the given table name. This function
--- should never fail, since the schema cache construction process is
--- supposed to ensure all dependencies are resolved.
-askTableInfo ::
-  forall b r m.
-  (Backend b, MonadTableInfo r m) =>
-  SourceName ->
-  TableName b ->
-  m (TableInfo b)
-askTableInfo sourceName tableName = do
-  tableInfo <- asks $ getTableInfo . getter
-  -- This should never fail, since the schema cache construction process is
-  -- supposed to ensure that all dependencies are resolved.
-  tableInfo `onNothing` throw500 ("askTableInfo: no info for table " <> dquote tableName <> " in source " <> dquote sourceName)
-  where
-    getTableInfo :: SourceCache -> Maybe (TableInfo b)
-    getTableInfo = Map.lookup tableName <=< unsafeSourceTables <=< Map.lookup sourceName
-
 -- | A wrapper around 'memoizeOn' that memoizes a function by using its argument
 -- as the key.
 memoize ::

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

@@ -522,7 +522,7 @@ buildQueryFields ::
   Maybe QueryTagsConfig ->
   m [P.FieldParser n (QueryRootField UnpreparedValue)]
 buildQueryFields sourceName sourceConfig tables (takeExposedAs FEAQuery -> functions) queryTagsConfig = do
-  roleName <- askRoleName
+  roleName <- asks getter
   functionPermsCtx <- asks $ qcFunctionPermsContext . getter
   tableSelectExpParsers <- for (Map.toList tables) \(tableName, tableInfo) -> do
     tableGQLName <- getTableGQLName @b tableInfo
@@ -573,7 +573,7 @@ buildMutationFields ::
   Maybe QueryTagsConfig ->
   m [P.FieldParser n (MutationRootField UnpreparedValue)]
 buildMutationFields scenario sourceName sourceConfig tables (takeExposedAs FEAMutation -> functions) queryTagsConfig = do
-  roleName <- askRoleName
+  roleName <- asks getter
   tableMutations <- for (Map.toList tables) \(tableName, tableInfo) -> do
     tableGQLName <- getTableGQLName @b tableInfo
     inserts <-
@@ -603,15 +603,8 @@ buildMutationFields scenario sourceName sourceConfig tables (takeExposedAs FEAMu
 -- | Prepare the parser for query-type GraphQL requests, but with introspection
 --   for queries, mutations and subscriptions built in.
 buildQueryParser ::
-  forall m n r.
+  forall r m n.
-  ( MonadSchema n m,
+  MonadBuildSchemaBase r m n =>
-    MonadTableInfo r m,
-    MonadRole r m,
-    Has QueryContext r,
-    Has P.MkTypename r,
-    Has MkRootFieldName r,
-    Has CustomizeRemoteFieldName r
-  ) =>
   [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] ->
   [P.FieldParser n (NamespacedField (RemoteSchemaRootField (RemoteRelationshipField UnpreparedValue) RemoteSchemaVariable))] ->
   [ActionInfo] ->
@@ -681,15 +674,8 @@ queryRootFromFields fps =
 -- exposed as a subscription along with fields to get the status of
 -- asynchronous actions.
 buildSubscriptionParser ::
-  forall m n r.
+  forall r m n.
-  ( MonadSchema n m,
+  MonadBuildSchemaBase r m n =>
-    MonadTableInfo r m,
-    MonadRole r m,
-    Has QueryContext r,
-    Has P.MkTypename r,
-    Has MkRootFieldName r,
-    Has CustomizeRemoteFieldName r
-  ) =>
   [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] ->
   [ActionInfo] ->
   AnnotatedCustomTypes ->
@@ -702,15 +688,8 @@ buildSubscriptionParser queryFields allActions customTypes = do
       <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
 
 buildMutationParser ::
-  forall m n r.
+  forall r m n.
-  ( MonadSchema n m,
+  MonadBuildSchemaBase r m n =>
-    MonadTableInfo r m,
-    MonadRole r m,
-    Has QueryContext r,
-    Has P.MkTypename r,
-    Has MkRootFieldName r,
-    Has CustomizeRemoteFieldName r
-  ) =>
   [P.FieldParser n (NamespacedField (RemoteSchemaRootField (RemoteRelationshipField UnpreparedValue) RemoteSchemaVariable))] ->
   [ActionInfo] ->
   AnnotatedCustomTypes ->

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

@@ -52,7 +52,7 @@ actionExecute ::
   ActionInfo ->
   m (Maybe (FieldParser n (AnnActionExecution (RQL.RemoteRelationshipField UnpreparedValue))))
 actionExecute customTypes actionInfo = runMaybeT do
-  roleName <- askRoleName
+  roleName <- asks getter
   guard (roleName == adminRoleName || roleName `Map.member` permissions)
   let fieldName = unActionName actionName
       description = G.Description <$> comment
@@ -90,13 +90,13 @@ actionExecute customTypes actionInfo = runMaybeT do
 --
 -- > action_name(action_input_arguments)
 actionAsyncMutation ::
-  forall m n r.
+  forall r m n.
-  (MonadSchema n m, MonadTableInfo r m, MonadRole r m) =>
+  MonadBuildSchemaBase r m n =>
   NonObjectTypeMap ->
   ActionInfo ->
   m (Maybe (FieldParser n AnnActionMutationAsync))
 actionAsyncMutation nonObjectTypeMap actionInfo = runMaybeT do
-  roleName <- lift askRoleName
+  roleName <- asks getter
   guard $ roleName == adminRoleName || roleName `Map.member` permissions
   inputArguments <- lift $ actionInputArguments nonObjectTypeMap $ _adArguments definition
   let fieldName = unActionName actionName
@@ -127,7 +127,7 @@ actionAsyncQuery ::
   ActionInfo ->
   m (Maybe (FieldParser n (AnnActionAsyncQuery ('Postgres 'Vanilla) (RQL.RemoteRelationshipField UnpreparedValue))))
 actionAsyncQuery objectTypes actionInfo = runMaybeT do
-  roleName <- askRoleName
+  roleName <- asks getter
   guard $ roleName == adminRoleName || roleName `Map.member` permissions
   createdAtFieldParser <-
     lift $ columnParser @('Postgres 'Vanilla) (ColumnScalar PGTimeStampTZ) (G.Nullability False)
@@ -294,8 +294,8 @@ mkDefinitionList (AOTObject AnnotatedObjectType {..}) =
       Map.unions $ map _trFieldMapping $ maybe [] toList _otdRelationships
 
 actionInputArguments ::
-  forall m n r.
+  forall r m n.
-  (MonadSchema n m, MonadTableInfo r m) =>
+  MonadBuildSchemaBase r m n =>
   NonObjectTypeMap ->
   [ArgumentDefinition (G.GType, NonObjectCustomType)] ->
   m (InputFieldsParser n J.Value)

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

@@ -18,7 +18,7 @@ import Hasura.GraphQL.Parser
 import Hasura.GraphQL.Parser qualified as P
 import Hasura.GraphQL.Parser.Class
 import Hasura.GraphQL.Schema.Backend
-import Hasura.GraphQL.Schema.Common (partialSQLExpToUnpreparedValue)
+import Hasura.GraphQL.Schema.Common (askTableInfo, partialSQLExpToUnpreparedValue)
 import Hasura.GraphQL.Schema.Table
 import Hasura.Prelude
 import Hasura.RQL.Types

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

@@ -14,6 +14,7 @@ module Hasura.GraphQL.Schema.Common
     SelectArgs,
     SelectExp,
     TablePerms,
+    askTableInfo,
     comparisonAggOperators,
     currentNodeIdVersion,
     mapField,
@@ -46,14 +47,16 @@ import Hasura.RQL.IR.Action qualified as IR
 import Hasura.RQL.IR.Root qualified as IR
 import Hasura.RQL.IR.Select qualified as IR
 import Hasura.RQL.Types
+import Hasura.Session (RoleName)
 import Language.GraphQL.Draft.Syntax as G
 
 -- | the set of common constraints required to build the schema
 type MonadBuildSchemaBase r m n =
   ( MonadError QErr m,
+    MonadReader r m,
     P.MonadSchema n m,
-    P.MonadTableInfo r m,
+    Has RoleName r,
-    P.MonadRole r m,
+    Has SourceCache r,
     Has QueryContext r,
     Has MkTypename r,
     Has MkRootFieldName r,
@@ -99,6 +102,24 @@ data QueryContext = QueryContext
     qcOptimizePermissionFilters :: Bool
   }
 
+-- | Looks up table information for the given table name. This function
+-- should never fail, since the schema cache construction process is
+-- supposed to ensure all dependencies are resolved.
+askTableInfo ::
+  forall b r m.
+  (Backend b, MonadError QErr m, MonadReader r m, Has SourceCache r) =>
+  SourceName ->
+  TableName b ->
+  m (TableInfo b)
+askTableInfo sourceName tableName = do
+  tableInfo <- asks $ getTableInfo . getter
+  -- This should never fail, since the schema cache construction process is
+  -- supposed to ensure that all dependencies are resolved.
+  tableInfo `onNothing` throw500 ("askTableInfo: no info for table " <> dquote tableName <> " in source " <> dquote sourceName)
+  where
+    getTableInfo :: SourceCache -> Maybe (TableInfo b)
+    getTableInfo = Map.lookup tableName <=< unsafeSourceTables <=< Map.lookup sourceName
+
 -- | Whether the request is sent with `x-hasura-use-backend-only-permissions` set to `true`.
 data Scenario = Backend | Frontend deriving (Enum, Show, Eq)
 

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

@@ -35,8 +35,8 @@ import Language.GraphQL.Draft.Syntax qualified as G
 -- >   obj-rel: <remote-table>_order_by
 -- > }
 orderByExp ::
-  forall m n r b.
+  forall b r m n.
-  (BackendSchema b, MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has P.MkTypename r) =>
+  MonadBuildSchema b r m n =>
   SourceName ->
   TableInfo b ->
   m (Parser 'Input n [IR.AnnotatedOrderByItemG b (UnpreparedValue b)])
@@ -116,8 +116,8 @@ orderByExp sourceName tableInfo = memoizeOn 'orderByExp (sourceName, tableInfoNa
 -- order, rather than using a general intermediary representation
 
 orderByAggregation ::
-  forall m n r b.
+  forall b r m n.
-  (BackendSchema b, MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has P.MkTypename r) =>
+  MonadBuildSchema b r m n =>
   SourceName ->
   TableInfo b ->
   m (Parser 'Input n [IR.OrderByItemG b (IR.AnnotatedAggregateOrderBy b)])

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

@@ -67,11 +67,11 @@ remoteRelationshipToSchemaField lhsFields RemoteSchemaFieldInfo {..} = runMaybeT
     -- The remote relationship field should not be accessible
     -- if the remote schema is not accessible to the said role
     hoistMaybe $ Map.lookup _rrfiRemoteSchemaName remoteRelationshipQueryCtx
-  role <- askRoleName
+  roleName <- asks getter
   let hasuraFieldNames = Map.keysSet lhsFields
       relationshipDef = ToSchemaRelationshipDef _rrfiRemoteSchemaName hasuraFieldNames _rrfiRemoteFields
   (newInpValDefns :: [G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition], remoteFieldParamMap) <-
-    if role == adminRoleName
+    if roleName == adminRoleName
       then do
         -- we don't validate the remote relationship when the role is admin
         -- because it's already been validated, when the remote relationship

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

@@ -58,12 +58,6 @@ import Hasura.GraphQL.Parser
   )
 import Hasura.GraphQL.Parser qualified as P
 import Hasura.GraphQL.Parser.Class
-  ( MonadParse (parseErrorWith, withPath),
-    MonadSchema (..),
-    MonadTableInfo,
-    askTableInfo,
-    parseError,
-  )
 import Hasura.GraphQL.Parser.Internal.Parser qualified as P
 import Hasura.GraphQL.Schema.Backend
 import Hasura.GraphQL.Schema.BoolExp
@@ -1394,7 +1388,7 @@ computedFieldPG sourceName ComputedFieldInfo {..} parentTable tableInfo = runMay
 -- | The custom SQL functions' input "args" field parser
 -- > function_name(args: function_args)
 customSQLFunctionArgs ::
-  (BackendSchema b, MonadSchema n m, MonadTableInfo r m, Has P.MkTypename r) =>
+  MonadBuildSchema b r m n =>
   FunctionInfo b ->
   G.Name ->
   G.Name ->
@@ -1421,12 +1415,8 @@ customSQLFunctionArgs FunctionInfo {..} functionName functionArgsName =
 --   table row argument in the case of computed fields), the args object will
 --   be omitted.
 functionArgs ::
-  forall b m n r.
+  forall b r m n.
-  ( BackendSchema b,
+  MonadBuildSchema b r m n =>
-    MonadSchema n m,
-    MonadTableInfo r m,
-    Has P.MkTypename r
-  ) =>
   FunctionTrackedAs b ->
   Seq.Seq (FunctionInputArgument b) ->
   m (InputFieldsParser n (IR.FunctionArgsExpTableRow (UnpreparedValue b)))

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

@@ -20,11 +20,12 @@ import Data.Text.Extended
 import Hasura.Base.Error (QErr)
 import Hasura.GraphQL.Parser (Kind (..), Parser)
 import Hasura.GraphQL.Parser qualified as P
-import Hasura.GraphQL.Parser.Class
 import Hasura.GraphQL.Schema.Backend
+import Hasura.GraphQL.Schema.Common
 import Hasura.Prelude
 import Hasura.RQL.DML.Internal (getRolePermInfo)
 import Hasura.RQL.Types
+import Hasura.Session (RoleName)
 import Language.GraphQL.Draft.Syntax qualified as G
 
 -- | Helper function to get the table GraphQL name. A table may have a
@@ -57,8 +58,8 @@ getTableGQLName tableInfo = do
 -- Return Nothing if there's no column the current user has "select"
 -- permissions for.
 tableSelectColumnsEnum ::
-  forall m n r b.
+  forall b r m n.
-  (BackendSchema b, MonadSchema n m, MonadRole r m, MonadTableInfo r m, Has P.MkTypename r) =>
+  MonadBuildSchema b r m n =>
   SourceName ->
   TableInfo b ->
   m (Maybe (Parser 'Both n (Column b)))
@@ -88,8 +89,8 @@ tableSelectColumnsEnum sourceName tableInfo = do
 -- table. Used for conflict resolution in "insert" mutations, among
 -- others. Maps to the table_update_column object.
 tableUpdateColumnsEnum ::
-  forall m n r b.
+  forall b r m n.
-  (BackendSchema b, MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has P.MkTypename r) =>
+  MonadBuildSchema b r m n =>
   TableInfo b ->
   m (Maybe (Parser 'Both n (Column b)))
 tableUpdateColumnsEnum tableInfo = do
@@ -127,24 +128,29 @@ updateColumnsPlaceholderParser tableInfo = do
             )
 
 tablePermissions ::
-  forall m n r b.
+  forall b r m.
-  (MonadSchema n m, MonadRole r m) =>
+  (MonadReader r m, Has RoleName r) =>
   TableInfo b ->
   m (Maybe (RolePermInfo b))
 tablePermissions tableInfo = do
-  roleName <- askRoleName
+  roleName <- asks getter
   pure $ getRolePermInfo roleName tableInfo
 
 tableSelectPermissions ::
-  forall b r m n.
+  forall b r m.
-  (MonadSchema n m, MonadRole r m) =>
+  (MonadReader r m, Has RoleName r) =>
   TableInfo b ->
   m (Maybe (SelPermInfo b))
 tableSelectPermissions tableInfo = (_permSel =<<) <$> tablePermissions tableInfo
 
 tableSelectFields ::
-  forall m n r b.
+  forall b r m.
-  (Backend b, MonadSchema n m, MonadTableInfo r m, MonadRole r m) =>
+  ( Backend b,
+    MonadError QErr m,
+    MonadReader r m,
+    Has SourceCache r,
+    Has RoleName r
+  ) =>
   SourceName ->
   TableInfo b ->
   m [FieldInfo b]
@@ -179,8 +185,13 @@ tableColumns tableInfo =
 -- | Get the columns of a table that my be selected under the given select
 -- permissions.
 tableSelectColumns ::
-  forall m n r b.
+  forall b r m.
-  (Backend b, MonadSchema n m, MonadTableInfo r m, MonadRole r m) =>
+  ( Backend b,
+    MonadError QErr m,
+    MonadReader r m,
+    Has SourceCache r,
+    Has RoleName r
+  ) =>
   SourceName ->
   TableInfo b ->
   m [ColumnInfo b]
@@ -193,8 +204,12 @@ tableSelectColumns sourceName tableInfo =
 -- | Get the columns of a table that my be updated under the given update
 -- permissions.
 tableUpdateColumns ::
-  forall m n r b.
+  forall b r m.
-  (Backend b, MonadSchema n m, MonadTableInfo r m, MonadRole r m) =>
+  ( Backend b,
+    MonadError QErr m,
+    MonadReader r m,
+    Has RoleName r
+  ) =>
   TableInfo b ->
   m [ColumnInfo b]
 tableUpdateColumns tableInfo = do

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

@@ -69,8 +69,8 @@ data UpdateOperator b m n op = UpdateOperator
 --   mutation query text or in update preset columns) and that each column is
 --   only used in one operator.
 buildUpdateOperators ::
-  forall b n r op m.
+  forall b r m n op.
-  (BackendSchema b, P.MonadSchema n m, P.MonadRole r m, P.MonadTableInfo r m) =>
+  MonadBuildSchema b r m n =>
   -- | Columns with @preset@ expressions
   (HashMap (Column b) op) ->
   -- | Update operators to include in the Schema
@@ -96,8 +96,8 @@ presetColumns = fmap partialSQLExpToUnpreparedValue . upiSet
 -- | Produce an InputFieldsParser from an UpdateOperator, but only if the operator
 -- applies to the table (i.e., it admits a non-empty column set).
 runUpdateOperator ::
-  forall b m n r op.
+  forall b r m n op.
-  (Backend b, P.MonadSchema n m, P.MonadRole r m, P.MonadTableInfo r m) =>
+  MonadBuildSchema b r m n =>
   TableInfo b ->
   UpdateOperator b m n op ->
   m