Cut ties with RQL.DML.Internal

## Description

As the name suggests, `DML.Internal` contains internal implementation details of RQL's DML. However, a lot of unrelated parts of the codebase still use some of the code it contains. This PR fixes this, and removes all imports of `RQL.DML.Internal` from outside of `RQL.DML`. Most of the time, this involves moving a function out of `DML.Internal` to an underlying module (see `getRolePermInfo`) or moving a function _back_ into it (see `checkRetCols`).

This PR also clarifies a bit the situation with `withTyAnn` and `withTypeAnn` by renaming the former into `withScalarTypeAnn` and moving them together. Worth noting: there might be a bug lurking in that function, as it doesn't seem to use the proper type annotations for some extension types!

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4380
GitOrigin-RevId: c8ae5b4e8378fefc0bcccf778d97813df727d3cb

server/src-lib/Hasura/Backends/Postgres/Execute/Mutation.hs

@@ -33,7 +33,6 @@ import Hasura.Base.Error
 import Hasura.EncJSON
 import Hasura.Prelude
 import Hasura.QueryTags
-import Hasura.RQL.DML.Internal
 import Hasura.RQL.IR.BoolExp
 import Hasura.RQL.IR.Delete
 import Hasura.RQL.IR.Insert

server/src-lib/Hasura/Backends/Postgres/Execute/Prepare.hs

@@ -34,7 +34,6 @@ import Hasura.GraphQL.Execute.Backend
 import Hasura.GraphQL.Parser.Column
 import Hasura.GraphQL.Parser.Schema
 import Hasura.Prelude
-import Hasura.RQL.DML.Internal (fromCurrentSession, withTypeAnn)
 import Hasura.RQL.Types.Column
 import Hasura.SQL.Backend
 import Hasura.Session
@@ -76,7 +75,10 @@ prepareWithPlan userInfo = \case
         `onNothing` throw400
           NotFound
           ("missing session variable: " <>> sessionVariableToText sessVar)
-    let sessVarVal = fromCurrentSession currentSessionExp sessVar
+    let sessVarVal =
+          S.SEOpApp
+            (S.SQLOp "->>")
+            [currentSessionExp, S.SELit $ sessionVariableToText sessVar]
     pure $ withTypeAnn ty sessVarVal
   UVLiteral sqlExp -> pure sqlExp
   UVSession -> pure currentSessionExp

server/src-lib/Hasura/Backends/Postgres/Execute/Types.hs

@@ -5,8 +5,9 @@
 module Hasura.Backends.Postgres.Execute.Types
   ( PGExecCtx (..),
     mkPGExecCtx,
-    defaultTxErrorHandler,
     mkTxErrorHandler,
+    defaultTxErrorHandler,
+    dmlTxErrorHandler,
 
     -- * Execution in a Postgres Source
     PGSourceConfig (..),
@@ -55,6 +56,18 @@ defaultTxErrorHandler = mkTxErrorHandler $ \case
   PGTransactionRollback _ -> True
   _ -> False
 
+-- | Constructs a transaction error handler tailored for the needs of RQL's DML.
+dmlTxErrorHandler :: Q.PGTxErr -> QErr
+dmlTxErrorHandler = mkTxErrorHandler $ \case
+  PGIntegrityConstraintViolation _ -> True
+  PGDataException _ -> True
+  PGSyntaxErrorOrAccessRuleViolation (Just (PGErrorSpecific code)) ->
+    code
+      `elem` [ PGUndefinedObject,
+               PGInvalidColumnReference
+             ]
+  _ -> False
+
 -- | Constructs a transaction error handler given a predicate that determines which errors are
 -- expected and should be reported to the user. All other errors are considered internal errors.
 mkTxErrorHandler :: (PGErrorType -> Bool) -> Q.PGTxErr -> QErr

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

@@ -33,7 +33,7 @@ import Hasura.Backends.Postgres.Execute.Prepare
     withUserVars,
   )
 import Hasura.Backends.Postgres.Execute.Subscription qualified as PGL
-import Hasura.Backends.Postgres.Execute.Types (PGSourceConfig (..))
+import Hasura.Backends.Postgres.Execute.Types (PGSourceConfig (..), dmlTxErrorHandler)
 import Hasura.Backends.Postgres.SQL.DML qualified as S
 import Hasura.Backends.Postgres.SQL.Types qualified as PG
 import Hasura.Backends.Postgres.SQL.Value qualified as PG
@@ -68,7 +68,6 @@ import Hasura.QueryTags
   ( QueryTagsComment (..),
     emptyQueryTagsComment,
   )
-import Hasura.RQL.DML.Internal (dmlTxErrorHandler)
 import Hasura.RQL.IR (MutationDB (..), QueryDB (..))
 import Hasura.RQL.IR.Delete qualified as IR
 import Hasura.RQL.IR.Insert qualified as IR

server/src-lib/Hasura/Backends/Postgres/SQL/DML.hs

@@ -90,7 +90,6 @@ module Hasura.Backends.Postgres.SQL.DML
     textArrTypeAnn,
     textTypeAnn,
     toAlias,
-    withTyAnn,
   )
 where
 
@@ -459,9 +458,6 @@ instance Cacheable SQLExp
 
 instance Hashable SQLExp
 
-withTyAnn :: PGScalarType -> SQLExp -> SQLExp
-withTyAnn colTy v = SETyAnn v . mkTypeAnn $ CollectableTypeScalar colTy
-
 instance J.ToJSON SQLExp where
   toJSON = J.toJSON . toSQLTxt
 

server/src-lib/Hasura/Backends/Postgres/SQL/Value.hs

@@ -15,6 +15,8 @@ module Hasura.Backends.Postgres.SQL.Value
     binEncoder,
     txtEncoder,
     toPrepParam,
+    withScalarTypeAnn,
+    withTypeAnn,
   )
 where
 
@@ -38,6 +40,7 @@ import Hasura.Backends.Postgres.SQL.Types
 import Hasura.Prelude
 import Hasura.SQL.GeoJSON
 import Hasura.SQL.Time
+import Hasura.SQL.Types
 import Hasura.SQL.Value (TxtEncodedVal (..))
 import PostgreSQL.Binary.Encoding qualified as PE
 
@@ -143,6 +146,16 @@ withConstructorFn ty v
   | ty == PGRaster = S.SEFnApp "ST_RastFromHexWKB" [v] Nothing
   | otherwise = v
 
+-- FIXME: shouldn't this also use 'withConstructorFn'?
+withScalarTypeAnn :: PGScalarType -> S.SQLExp -> S.SQLExp
+withScalarTypeAnn colTy v = S.SETyAnn v . S.mkTypeAnn $ CollectableTypeScalar colTy
+
+withTypeAnn :: CollectableType PGScalarType -> S.SQLExp -> S.SQLExp
+withTypeAnn ty expr = flip S.SETyAnn (S.mkTypeAnn ty) $
+  case ty of
+    CollectableTypeScalar baseTy -> withConstructorFn baseTy expr
+    CollectableTypeArray _ -> expr
+
 -- TODO: those two functions are useful outside of Postgres, and
 -- should be moved to a common place of the code. Perhaps the Prelude?
 scientificToInteger :: (Integral i, Bounded i) => Scientific -> AT.Parser i
@@ -336,4 +349,4 @@ Also see https://github.com/hasura/graphql-engine/issues/2818
 toPrepParam :: Int -> PGScalarType -> S.SQLExp
 toPrepParam i ty =
   -- See Note [Type casting prepared params] above
-  S.withTyAnn ty . withConstructorFn ty $ S.SEPrep i
+  withScalarTypeAnn ty . withConstructorFn ty $ S.SEPrep i

server/src-lib/Hasura/Backends/Postgres/Translate/Column.hs

@@ -18,7 +18,7 @@ import Hasura.SQL.Backend
 
 toTxtValue :: ColumnValue ('Postgres pgKind) -> SQLExp
 toTxtValue ColumnValue {..} =
-  withTyAnn ty . withConstructorFn ty $ txtEncoder cvValue
+  withScalarTypeAnn ty . withConstructorFn ty $ txtEncoder cvValue
   where
     ty = unsafePGColumnToBackend cvType
 

server/src-lib/Hasura/Backends/Postgres/Translate/Mutation.hs

@@ -67,4 +67,4 @@ mkSelectExpFromColumnValues qt allCols = \case
     txtEncodedToSQLExp colTy = \case
       TENull -> S.SENull
       TELit textValue ->
-        S.withTyAnn (unsafePGColumnToBackend colTy) $ S.SELit textValue
+        withScalarTypeAnn (unsafePGColumnToBackend colTy) $ S.SELit textValue

server/src-lib/Hasura/Backends/Postgres/Translate/Returning.hs

@@ -11,7 +11,6 @@ module Hasura.Backends.Postgres.Translate.Returning
     mkMutationOutputExp,
     checkConstraintIdentifier,
     asCheckErrorExtractor,
-    checkRetCols,
   )
 where
 
@@ -19,19 +18,15 @@ import Data.Coerce
 import Hasura.Backends.Postgres.SQL.DML qualified as S
 import Hasura.Backends.Postgres.SQL.Types
 import Hasura.Backends.Postgres.Translate.Select
-import Hasura.Base.Error
 import Hasura.Prelude
-import Hasura.RQL.DML.Internal
 import Hasura.RQL.IR.BoolExp
 import Hasura.RQL.IR.Returning
 import Hasura.RQL.IR.Select
 import Hasura.RQL.Types.Backend
 import Hasura.RQL.Types.Column
 import Hasura.RQL.Types.Common
-import Hasura.RQL.Types.SchemaCache
 import Hasura.RQL.Types.Table
 import Hasura.SQL.Backend
-import Hasura.Session
 
 -- | The postgres common table expression (CTE) for mutation queries.
 -- This CTE expression is used to generate mutation field output expression,
@@ -204,15 +199,3 @@ checkConstraintIdentifier = Identifier "check__constraint"
 asCheckErrorExtractor :: S.SQLExp -> S.Extractor
 asCheckErrorExtractor s =
   S.Extractor s $ Just $ S.Alias checkConstraintIdentifier
-
-checkRetCols ::
-  (Backend ('Postgres pgKind), UserInfoM m, QErrM m) =>
-  FieldInfoMap (FieldInfo ('Postgres pgKind)) ->
-  SelPermInfo ('Postgres pgKind) ->
-  [PGCol] ->
-  m [ColumnInfo ('Postgres pgKind)]
-checkRetCols fieldInfoMap selPermInfo cols = do
-  mapM_ (checkSelOnCol selPermInfo) cols
-  forM cols $ \col -> askColInfo fieldInfoMap col relInRetErr
-  where
-    relInRetErr = "Relationships can't be used in \"returning\"."

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

@@ -57,7 +57,6 @@ import Hasura.Prelude
 import Hasura.RQL.DDL.Headers
 import Hasura.RQL.DDL.Webhook.Transform
 import Hasura.RQL.DDL.Webhook.Transform.Class (mkReqTransformCtx)
-import Hasura.RQL.DML.Internal (dmlTxErrorHandler)
 import Hasura.RQL.IR.Action qualified as RA
 import Hasura.RQL.IR.BoolExp
 import Hasura.RQL.IR.Select qualified as RS

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

@@ -24,7 +24,6 @@ import Hasura.GraphQL.Parser.Constants qualified as G
 import Hasura.GraphQL.Schema.Backend
 import Hasura.GraphQL.Schema.Common
 import Hasura.Prelude
-import Hasura.RQL.DML.Internal (getRolePermInfo)
 import Hasura.RQL.Types.Backend
 import Hasura.RQL.Types.Column
 import Hasura.RQL.Types.Common

server/src-lib/Hasura/RQL/DDL/Permission.hs

@@ -37,7 +37,6 @@ import Hasura.Base.Error
 import Hasura.EncJSON
 import Hasura.Prelude
 import Hasura.RQL.DDL.Permission.Internal
-import Hasura.RQL.DML.Internal
 import Hasura.RQL.IR.BoolExp
 import Hasura.RQL.Types.Backend
 import Hasura.RQL.Types.Column
@@ -286,7 +285,9 @@ buildSelPermInfo source tn fieldInfoMap sp = withPathK "permission" $ do
       depHeaders = getDependentHeaders $ spFilter sp
       mLimit = spLimit sp
 
-  withPathK "limit" $ mapM_ onlyPositiveInt mLimit
+  withPathK "limit" $ for_ mLimit \value ->
+    when (value < 0) $
+      throw400 NotSupported "unexpected negative value"
 
   let pgColsWithFilter = HM.fromList $ map (,Nothing) pgCols
       scalarComputedFieldsWithFilter = HS.toMap (HS.fromList scalarComputedFields) $> Nothing

server/src-lib/Hasura/RQL/DML/Internal.hs

@@ -8,17 +8,14 @@ module Hasura.RQL.DML.Internal
     askUpdPermInfo,
     binRHSBuilder,
     checkPermOnCol,
+    checkRetCols,
     checkSelOnCol,
     convAnnBoolExpPartialSQL,
     convAnnColumnCaseBoolExpPartialSQL,
     convBoolExp,
     convPartialSQLExp,
-    dmlTxErrorHandler,
     fetchRelDet,
     fetchRelTabInfo,
-    fromCurrentSession,
-    getPermInfoMaybe,
-    getRolePermInfo,
     isTabUpdatable,
     onlyPositiveInt,
     runDMLP1T,
@@ -26,7 +23,6 @@ module Hasura.RQL.DML.Internal
     validateHeaders,
     valueParserWithCollectableType,
     verifyAsrns,
-    withTypeAnn,
   )
 where
 
@@ -38,9 +34,7 @@ import Data.Sequence qualified as DS
 import Data.Text qualified as T
 import Data.Text.Extended
 import Database.PG.Query qualified as Q
-import Hasura.Backends.Postgres.Execute.Types
 import Hasura.Backends.Postgres.SQL.DML qualified as S
-import Hasura.Backends.Postgres.SQL.Error
 import Hasura.Backends.Postgres.SQL.Types hiding (TableName)
 import Hasura.Backends.Postgres.SQL.Value
 import Hasura.Backends.Postgres.Translate.BoolExp
@@ -96,14 +90,6 @@ getPermInfoMaybe ::
 getPermInfoMaybe role pa tableInfo =
   getRolePermInfo role tableInfo ^. pa
 
-getRolePermInfo ::
-  RoleName -> TableInfo b -> RolePermInfo b
-getRolePermInfo role tableInfo
-  | role == adminRoleName = _tiAdminRolePermInfo tableInfo
-  | otherwise =
-    fromMaybe (RolePermInfo Nothing Nothing Nothing Nothing) $
-      M.lookup role (_tiRolePermInfoMap tableInfo)
-
 assertAskPermInfo ::
   (UserInfoM m, QErrM m, Backend b) =>
   PermType ->
@@ -155,6 +141,18 @@ askDelPermInfo = assertAskPermInfo PTDelete permDel
 verifyAsrns :: (MonadError QErr m) => [a -> m ()] -> [a] -> m ()
 verifyAsrns preds xs = indexedForM_ xs $ \a -> mapM_ ($ a) preds
 
+checkRetCols ::
+  (Backend ('Postgres pgKind), UserInfoM m, QErrM m) =>
+  FieldInfoMap (FieldInfo ('Postgres pgKind)) ->
+  SelPermInfo ('Postgres pgKind) ->
+  [PGCol] ->
+  m [ColumnInfo ('Postgres pgKind)]
+checkRetCols fieldInfoMap selPermInfo cols = do
+  mapM_ (checkSelOnCol selPermInfo) cols
+  forM cols $ \col -> askColInfo fieldInfoMap col relInRetErr
+  where
+    relInRetErr = "Relationships can't be used in \"returning\"."
+
 checkSelOnCol ::
   forall b m.
   (UserInfoM m, QErrM m, Backend b) =>
@@ -349,12 +347,6 @@ sessVarFromCurrentSetting' :: CollectableType PGScalarType -> SessionVariable ->
 sessVarFromCurrentSetting' ty sessVar =
   withTypeAnn ty $ fromCurrentSession currentSession sessVar
 
-withTypeAnn :: CollectableType PGScalarType -> S.SQLExp -> S.SQLExp
-withTypeAnn ty sessVarVal = flip S.SETyAnn (S.mkTypeAnn ty) $
-  case ty of
-    CollectableTypeScalar baseTy -> withConstructorFn baseTy sessVarVal
-    CollectableTypeArray _ -> sessVarVal
-
 fromCurrentSession ::
   S.SQLExp ->
   SessionVariable ->
@@ -390,17 +382,6 @@ convBoolExp cim spi be sessVarBldr rootTable rhsParser = do
   abe <- annBoolExp boolExpRHSParser rootTable cim $ unBoolExp be
   checkSelPerm spi sessVarBldr abe
 
-dmlTxErrorHandler :: Q.PGTxErr -> QErr
-dmlTxErrorHandler = mkTxErrorHandler $ \case
-  PGIntegrityConstraintViolation _ -> True
-  PGDataException _ -> True
-  PGSyntaxErrorOrAccessRuleViolation (Just (PGErrorSpecific code)) ->
-    code
-      `elem` [ PGUndefinedObject,
-               PGInvalidColumnReference
-             ]
-  _ -> False
-
 -- validate headers
 validateHeaders :: (UserInfoM m, QErrM m) => HashSet Text -> m ()
 validateHeaders depHeaders = do

server/src-lib/Hasura/RQL/Types/Table.hs

@@ -57,6 +57,7 @@ module Hasura.RQL.Types.Table
     pkConstraint,
     sortCols,
     tableInfoName,
+    getRolePermInfo,
     tcCustomName,
     tcCustomRootFields,
     tcComment,
@@ -836,6 +837,14 @@ tiName = tiCoreInfo . tciName
 tableInfoName :: TableInfo b -> TableName b
 tableInfoName = view tiName
 
+getRolePermInfo :: RoleName -> TableInfo b -> RolePermInfo b
+getRolePermInfo role tableInfo
+  | role == adminRoleName = _tiAdminRolePermInfo tableInfo
+  | otherwise =
+    fromMaybe
+      (RolePermInfo Nothing Nothing Nothing Nothing)
+      (M.lookup role $ _tiRolePermInfoMap tableInfo)
+
 type TableCoreCache b = M.HashMap (TableName b) (TableCoreInfo b)
 
 type TableCache b = M.HashMap (TableName b) (TableInfo b) -- info of all tables