chore(server): fix Logical Model permissions for nested fields

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

server/lib/api-tests/src/Test/Queries/NativeQueries/NativeQueriesSpec.hs

@@ -786,6 +786,69 @@ tests = do
 
       shouldReturnYaml testEnvironment actual expected
 
+    it "Adding a native query with a valid array relationship returns table data along with results when permissions are sufficient" $ \testEnvironment -> do
+      let backendTypeMetadata = fromMaybe (error "Unknown backend") $ getBackendTypeConfig testEnvironment
+          sourceName = BackendType.backendSourceName backendTypeMetadata
+          schemaName = Schema.getSchemaName testEnvironment
+          backendType = BackendType.backendTypeString backendTypeMetadata
+
+          schemaKeyword :: String
+          schemaKeyword = Key.toString $ Fixture.backendSchemaKeyword backendTypeMetadata
+
+      Schema.trackLogicalModel sourceName articleLogicalModel testEnvironment
+      Schema.trackLogicalModel sourceName authorLogicalModel testEnvironment
+      Schema.trackNativeQuery sourceName (nativeQueryWithRelationship schemaKeyword schemaName) testEnvironment
+
+      void $
+        GraphqlEngine.postMetadata
+          testEnvironment
+          [interpolateYaml|
+              type: bulk
+              args:
+                - type: #{backendType}_create_logical_model_select_permission
+                  args:
+                    source: #{sourceName}
+                    name: author
+                    role: "sufficient"
+                    permission:
+                      columns: "*"
+                      filter: {}
+            |]
+
+      let expected =
+            [yaml|
+                data:
+                  relationship_test:
+                    - id: 1
+                      name: "Marenghi"
+                      articles:
+                        - title: "Fright Knight"
+                    - id: 2
+                      name: "Learner"
+                      articles:
+                        - title: "Man to Man"
+              |]
+
+          actual :: IO Value
+          actual =
+            GraphqlEngine.postGraphqlWithHeaders
+              testEnvironment
+              [ ("X-Hasura-Role", "sufficient")
+              ]
+              [graphql|
+              query {
+                relationship_test {
+                  id
+                  name
+                  articles {
+                    title
+                  }
+                }
+              }
+           |]
+
+      shouldReturnYaml testEnvironment actual expected
+
     -- I don't think this is the test we want - ideally checks of this kind
     -- would happen before the resolve the schema
     -- however for now let's just check that doing a stupid thing is not

server/src-lib/Hasura/LogicalModel/Common.hs

@@ -1,17 +1,20 @@
 module Hasura.LogicalModel.Common
   ( toFieldInfo,
     columnsFromFields,
+    logicalModelFieldsToFieldInfo,
   )
 where
 
+import Data.Bifunctor (bimap)
+import Data.HashMap.Strict qualified as Map
 import Data.HashMap.Strict.InsOrd qualified as InsOrd
 import Data.Text.Extended (ToTxt (toTxt))
 import Hasura.LogicalModel.Types (LogicalModelField (..))
 import Hasura.NativeQuery.Types (NullableScalarType (..))
 import Hasura.Prelude
 import Hasura.RQL.Types.Backend (Backend (..))
-import Hasura.RQL.Types.Column (ColumnInfo (..), ColumnMutability (..), ColumnType (..))
+import Hasura.RQL.Types.Column (ColumnInfo (..), ColumnMutability (..), ColumnType (..), fromCol)
-import Hasura.RQL.Types.Table (FieldInfo (..))
+import Hasura.RQL.Types.Table (FieldInfo (..), FieldInfoMap)
 import Language.GraphQL.Draft.Syntax qualified as G
 
 columnsFromFields ::
@@ -34,20 +37,34 @@ toFieldInfo fields =
   traverseWithIndex
     (\i -> fmap FIColumn . logicalModelToColumnInfo i)
     (InsOrd.toList fields)
-  where
-    traverseWithIndex :: (Applicative m) => (Int -> aa -> m bb) -> [aa] -> m [bb]
-    traverseWithIndex f = zipWithM f [0 ..]
 
-    logicalModelToColumnInfo :: Int -> (Column b, NullableScalarType b) -> Maybe (ColumnInfo b)
+traverseWithIndex :: (Applicative m) => (Int -> aa -> m bb) -> [aa] -> m [bb]
-    logicalModelToColumnInfo i (column, NullableScalarType {..}) = do
+traverseWithIndex f = zipWithM f [0 ..]
-      name <- G.mkName (toTxt column)
+
-      pure $
+logicalModelToColumnInfo :: forall b. (Backend b) => Int -> (Column b, NullableScalarType b) -> Maybe (ColumnInfo b)
-        ColumnInfo
+logicalModelToColumnInfo i (column, NullableScalarType {..}) = do
-          { ciColumn = column,
+  name <- G.mkName (toTxt column)
-            ciName = name,
+  pure $
-            ciPosition = i,
+    ColumnInfo
-            ciType = ColumnScalar nstType,
+      { ciColumn = column,
-            ciIsNullable = nstNullable,
+        ciName = name,
-            ciDescription = G.Description <$> nstDescription,
+        ciPosition = i,
-            ciMutability = ColumnMutability {_cmIsInsertable = False, _cmIsUpdatable = False}
+        ciType = ColumnScalar nstType,
-          }
+        ciIsNullable = nstNullable,
+        ciDescription = G.Description <$> nstDescription,
+        ciMutability = ColumnMutability {_cmIsInsertable = False, _cmIsUpdatable = False}
+      }
+
+logicalModelFieldsToFieldInfo ::
+  forall b.
+  (Backend b) =>
+  InsOrd.InsOrdHashMap (Column b) (LogicalModelField b) ->
+  FieldInfoMap (FieldInfo b)
+logicalModelFieldsToFieldInfo =
+  Map.fromList
+    . fmap (bimap (fromCol @b) FIColumn)
+    . fromMaybe mempty
+    . traverseWithIndex
+      (\i (column, lmf) -> (,) column <$> logicalModelToColumnInfo i (column, lmf))
+    . InsOrd.toList
+    . columnsFromFields

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

@@ -41,7 +41,8 @@ import Data.Sequence qualified as Seq
 import Data.Text.Extended
 import Hasura.Base.Error
 import Hasura.EncJSON
-import Hasura.LogicalModel.Types (LogicalModelName)
+import Hasura.LogicalModel.Common (logicalModelFieldsToFieldInfo)
+import Hasura.LogicalModel.Types (LogicalModelField (..), LogicalModelName)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Permission.Internal
 import Hasura.RQL.IR.BoolExp
@@ -245,7 +246,7 @@ buildLogicalModelPermInfo ::
   ) =>
   SourceName ->
   LogicalModelName ->
-  FieldInfoMap (FieldInfo b) ->
+  OMap.InsOrdHashMap (Column b) (LogicalModelField b) ->
   PermDefPermission b perm ->
   m (WithDeps (PermInfo perm b))
 buildLogicalModelPermInfo sourceName logicalModelName fieldInfoMap = \case
@@ -431,17 +432,19 @@ buildLogicalModelSelPermInfo ::
   ) =>
   SourceName ->
   LogicalModelName ->
-  FieldInfoMap (FieldInfo b) ->
+  OMap.InsOrdHashMap (Column b) (LogicalModelField b) ->
   SelPerm b ->
   m (WithDeps (SelPermInfo b))
-buildLogicalModelSelPermInfo source logicalModelName fieldInfoMap sp = withPathK "permission" do
+buildLogicalModelSelPermInfo source logicalModelName logicalModelFieldMap sp = withPathK "permission" do
   let columns :: [Column b]
-      columns = interpColSpec (ciColumn <$> getCols fieldInfoMap) (spColumns sp)
+      columns = interpColSpec (lmfName <$> OMap.elems logicalModelFieldMap) (spColumns sp)
 
   -- Interpret the row permissions in the 'SelPerm' definition.
+  -- TODO: do row permisions work on non-scalar fields? Going to assume not and
+  -- filter out the non-scalars.
   (spiFilter, boolExpDeps) <-
     withPathK "filter" $
-      procLogicalModelBoolExp source logicalModelName fieldInfoMap (spFilter sp)
+      procLogicalModelBoolExp source logicalModelName (logicalModelFieldsToFieldInfo logicalModelFieldMap) (spFilter sp)
 
   let -- What parts of the metadata are interesting when computing the
       -- permissions? These dependencies bubble all the way up to

server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs

@@ -46,7 +46,6 @@ import Hasura.GraphQL.Schema.NamingCase
 import Hasura.Incremental qualified as Inc
 import Hasura.Logging
 import Hasura.LogicalModel.Cache (LogicalModelCache, LogicalModelInfo (..))
-import Hasura.LogicalModel.Common (columnsFromFields, toFieldInfo)
 import Hasura.LogicalModel.Metadata (LogicalModelMetadata (..))
 import Hasura.Metadata.Class
 import Hasura.NativeQuery.Cache (NativeQueryCache, NativeQueryInfo (..))
@@ -768,12 +767,8 @@ buildSchemaCacheRule logger env = proc (MetadataWithResourceVersion metadataNoDe
                 unless (_cdcAreNativeQueriesEnabled dynamicConfig) $
                   throw400 InvalidConfiguration "The Logical Model feature is disabled"
 
-                fieldInfoMap <- case toFieldInfo (columnsFromFields _lmmFields) of
-                  Nothing -> pure mempty
-                  Just fields -> pure (mapFromL fieldInfoName fields)
-
                 logicalModelPermissions <-
-                  buildLogicalModelPermissions sourceName tableCoreInfos _lmmName fieldInfoMap _lmmSelectPermissions orderedRoles
+                  buildLogicalModelPermissions sourceName tableCoreInfos _lmmName _lmmFields _lmmSelectPermissions orderedRoles
 
                 pure
                   LogicalModelInfo

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

@@ -17,7 +17,7 @@ import Data.Sequence qualified as Seq
 import Data.Text.Extended
 import Hasura.Base.Error
 import Hasura.LogicalModel.Metadata (WithLogicalModel (..))
-import Hasura.LogicalModel.Types (LogicalModelName)
+import Hasura.LogicalModel.Types (LogicalModelField (..), LogicalModelName)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Permission
 import Hasura.RQL.DDL.Schema.Cache.Common
@@ -292,7 +292,7 @@ buildLogicalModelPermissions ::
   SourceName ->
   TableCoreCache b ->
   LogicalModelName ->
-  FieldInfoMap (FieldInfo b) ->
+  InsOrdHashMap (Column b) (LogicalModelField b) ->
   InsOrdHashMap RoleName (SelPermDef b) ->
   OrderedRoles ->
   m (RolePermInfoMap b)