[PATCH pve-access-control v2 05/10] fix #7294: acl: pool: add SDN VNets as pool members

[David Riley <d.riley@proxmox.com>]

Extend the pool configuration to allow SDN VNets as pool members by
introducing a new 'network' property.

The property tracks entries using a type prefix for future expansion:
* vnet/<zone>/<vnet>
* vnet/<zone>/<vnet>/<vlan>

Adapt the path resolution for bridges to ensure pool configurations
are considered. This is necessary to allow users to assign a VNet to
a VM when they only have access to a specific VLAN tag. Note that if
a VLAN tag is present in the pool configuration, the user is
restricted to that specific tag and cannot assign the base VNet
untagged.

Update the parser_writer tests to verify serialization and parsing
of the updated configuration format.

Link: https://bugzilla.proxmox.com/show_bug.cgi?id=7294
Signed-off-by: David Riley <d.riley@proxmox.com>
---
 src/PVE/AccessControl.pm  | 93 ++++++++++++++++++++++++++++++++++++---
 src/PVE/RPCEnvironment.pm | 68 ++++++++++++++++++++++++++--
 src/test/parser_writer.pl | 53 ++++++++++++++++++----
 3 files changed, 198 insertions(+), 16 deletions(-)

diff --git a/src/PVE/AccessControl.pm b/src/PVE/AccessControl.pm
index 34e56b6..6217f10 100644
--- a/src/PVE/AccessControl.pm
+++ b/src/PVE/AccessControl.pm
@@ -1559,7 +1559,7 @@ sub parse_user_config {
                 warn "user config - ignore invalid path in acl '$pathtxt'\n";
             }
         } elsif ($et eq 'pool') {
-            my ($pool, $comment, $vmlist, $storelist) = @data;
+            my ($pool, $comment, $vmlist, $storelist, $networklist) = @data;
 
             if (!verify_poolname($pool, 1)) {
                 warn "user config - ignore pool '$pool' - invalid characters in pool name\n";
@@ -1567,7 +1567,7 @@ sub parse_user_config {
             }
 
             # make sure to add the pool (even if there are no members)
-            $cfg->{pools}->{$pool} = { vms => {}, storage => {}, pools => {} }
+            $cfg->{pools}->{$pool} = { vms => {}, storage => {}, pools => {}, network => {} }
                 if !$cfg->{pools}->{$pool};
 
             if ($pool =~ m!/!) {
@@ -1576,8 +1576,12 @@ sub parse_user_config {
                     # ensure nested pool info is correctly recorded
                     my $parent = $1;
                     $cfg->{pools}->{$curr}->{parent} = $parent;
-                    $cfg->{pools}->{$parent} = { vms => {}, storage => {}, pools => {} }
-                        if !$cfg->{pools}->{$parent};
+
+                    if (!$cfg->{pools}->{$parent}) {
+                        $cfg->{pools}->{$parent} =
+                            { vms => {}, storage => {}, pools => {}, network => {} };
+                    }
+
                     $cfg->{pools}->{$parent}->{pools}->{$curr} = 1;
                     $curr = $parent;
                 }
@@ -1610,6 +1614,18 @@ sub parse_user_config {
                 }
                 $cfg->{pools}->{$pool}->{storage}->{$storeid} = 1;
             }
+
+            for my $network (split_list($networklist)) {
+
+                if ($network !~ m/^[a-z0-9][a-z0-9\-_]*(?:\/[a-z0-9][a-z0-9\-_]*)*$/i) {
+                    warn "user config - ignore invalid sdn resource entry '$network' in pool"
+                        . " '$pool'\n";
+                    next;
+                }
+
+                $cfg->{pools}->{$pool}->{network}->{$network} = 1;
+            }
+
         } elsif ($et eq 'token') {
             my ($tokenid, $expire, $privsep, $comment) = @data;
 
@@ -1691,8 +1707,9 @@ sub write_user_config {
         my $d = $cfg->{pools}->{$pool};
         my $vmlist = join(',', sort keys %{ $d->{vms} });
         my $storelist = join(',', sort keys %{ $d->{storage} });
+        my $networklist = join(',', sort keys %{ $d->{network} });
         my $comment = $d->{comment} ? PVE::Tools::encode_text($d->{comment}) : '';
-        $data .= "pool:$pool:$comment:$vmlist:$storelist:\n";
+        $data .= "pool:$pool:$comment:$vmlist:$storelist:$networklist:\n";
     }
 
     $data .= "\n";
@@ -1974,6 +1991,72 @@ sub remove_vm_from_pool {
     lock_user_config($delVMfromPoolFn, "pool cleanup for VM $vmid failed");
 }
 
+sub remove_vnet_from_pool {
+    my ($zone, $vnet) = @_;
+    my $network_key = "vnet/$zone/$vnet";
+
+    my $del_vnet_from_pool_fn = sub {
+        my $usercfg = cfs_read_file("user.cfg");
+        return if !$usercfg->{pools};
+
+        my $modified = 0;
+        for my $pool (keys $usercfg->{pools}->%*) {
+            my $pool_cfg = $usercfg->{pools}->{$pool};
+            next if !$pool_cfg->{network};
+
+            for my $net_key (keys $pool_cfg->{network}->%*) {
+                if ($net_key eq $network_key || $net_key =~ m!^\Q$network_key\E/\d+$!) {
+                    delete $pool_cfg->{network}->{$net_key};
+                    $modified = 1;
+                }
+            }
+        }
+
+        if ($modified) {
+            cfs_write_file("user.cfg", $usercfg);
+        }
+    };
+
+    lock_user_config($del_vnet_from_pool_fn, "pool cleanup for VNet $vnet failed");
+}
+
+sub migrate_vnet_zone_in_pool {
+    my ($src_zone, $dest_zone, $vnet) = @_;
+
+    my $src_key = "vnet/$src_zone/$vnet";
+    my $dest_key = "vnet/$dest_zone/$vnet";
+
+    my $update_vnet_zone_fn = sub {
+        my $usercfg = cfs_read_file("user.cfg");
+        return if !$usercfg->{pools};
+
+        my $modified = 0;
+        for my $pool (keys $usercfg->{pools}->%*) {
+            my $pool_cfg = $usercfg->{pools}->{$pool};
+            next if !$pool_cfg->{network};
+
+            for my $net_key (keys $pool_cfg->{network}->%*) {
+                if ($net_key eq $src_key || $net_key =~ m!^\Q$src_key\E/(\d+)$!) {
+                    my $vlan = $1;
+                    delete $pool_cfg->{network}->{$net_key};
+
+                    my $target_key = $dest_key;
+                    $target_key .= "/$vlan" if defined($vlan);
+                    $pool_cfg->{network}->{$target_key} = 1;
+
+                    $modified = 1;
+                }
+            }
+        }
+
+        if ($modified) {
+            cfs_write_file("user.cfg", $usercfg);
+        }
+    };
+
+    lock_user_config($update_vnet_zone_fn, "pool update for VNet $vnet failed");
+}
+
 sub remove_sdn_resource_access {
     my ($paths) = @_; # [ ['zones', '<zone>'], ['zones', '<zone>', '<vnet>'] ]
 
diff --git a/src/PVE/RPCEnvironment.pm b/src/PVE/RPCEnvironment.pm
index 7591aa9..d9372a0 100644
--- a/src/PVE/RPCEnvironment.pm
+++ b/src/PVE/RPCEnvironment.pm
@@ -53,6 +53,21 @@ my $compile_acl_path = sub {
                     $data->{poolroles}->{"/storage/$storeid"}->{$role} = 1;
                 }
             }
+
+            for my $network_key (keys $d->{network}->%*) {
+                my ($type, @path) = split('/', $network_key);
+
+                if ($type eq 'vnet') {
+                    my ($zoneid, $vnetid, $vlan) = @path;
+
+                    my $acl_path = "/sdn/zones/$zoneid/$vnetid";
+                    $acl_path = "$acl_path/$vlan" if defined($vlan);
+
+                    for my $role (keys $pool_roles->%*) {
+                        $data->{poolroles}->{$acl_path}->{$role} = 1;
+                    }
+                }
+            }
         }
     }
 
@@ -63,15 +78,30 @@ my $compile_acl_path = sub {
     # means the role is set
     my $roles = PVE::AccessControl::roles($cfg, $user, $path);
 
+    my $poolroles_path = $data->{poolroles}->{$path};
+
+    # Pool ACL paths are setup without propagation, therefore checking
+    # /sdn/zones/<zone>/<vnet>/<tag> fails even if the user has the
+    # permission for the base path /sdn/zones/<zone>/<vnet>.
+    # To allow this, the roles of the base VNet path are looked up if
+    # the exact tagged path is not found in the pool.
+    if (!defined($poolroles_path) && $path =~ m|^/sdn/zones/[^/]+/[^/]+/\d+$|) {
+        my @parts = split('/', $path);
+        my $base_vnet_path = join('/', @parts[0 .. 4]); # remove tag
+
+        # Inherit the permissions of the base VNet path for this request
+        $poolroles_path = $data->{poolroles}->{$base_vnet_path};
+    }
+
     # apply roles inherited from pools
-    if ($data->{poolroles}->{$path}) {
+    if ($poolroles_path) {
         # NoAccess must not be trumped by pool ACLs
         if (!defined($roles->{NoAccess})) {
-            if ($data->{poolroles}->{$path}->{NoAccess}) {
+            if ($poolroles_path->{NoAccess}) {
                 # but pool ACL NoAccess trumps regular ACL
                 $roles = { 'NoAccess' => 0 };
             } else {
-                foreach my $role (keys %{ $data->{poolroles}->{$path} }) {
+                for my $role (keys $poolroles_path->%*) {
                     # only use role from pool ACL if regular ACL didn't already
                     # set it, and never set propagation for pool-derived ACLs
                     $roles->{$role} = 0 if !defined($roles->{$role});
@@ -219,6 +249,8 @@ sub compute_api_permission {
                     $res->{vms}->{$priv} = 1;
                 } elsif ($priv =~ m/^Datastore\./) {
                     $res->{storage}->{$priv} = 1;
+                } elsif ($priv =~ m/^SDN\./) {
+                    $res->{sdn}->{$priv} = 1;
                 } elsif ($priv eq 'Permissions.Modify') {
                     $res->{storage}->{$priv} = 1;
                     $res->{vms}->{$priv} = 1;
@@ -274,6 +306,17 @@ sub get_effective_permissions {
         foreach my $storeid (keys %{ $d->{storage} }) {
             $paths->{"/storage/$storeid"} = 1;
         }
+
+        for my $network_key (keys $d->{network}->%*) {
+            my ($type, @path) = split('/', $network_key);
+
+            if ($type eq 'vnet') {
+                my ($zoneid, $vnetid, $vlan) = @path;
+                my $vnet_path = "/sdn/zones/$zoneid/$vnetid";
+                $vnet_path .= "/$vlan" if defined($vlan);
+                $paths->{$vnet_path} = 1;
+            }
+        }
     }
 
     my $perms = {};
@@ -353,6 +396,25 @@ sub check_sdn_bridge {
         }
     }
 
+    # check access to VLANs via pools
+    for my $pool (keys $cfg->{pools}->%*) {
+        my $poolcfg = $cfg->{pools}->{$pool};
+        next if !$poolcfg->{network};
+
+        for my $network_key (keys $poolcfg->{network}->%*) {
+            my ($type, @path) = split('/', $network_key);
+
+            if (defined($type) && $type eq 'vnet') {
+                my ($zoneid, $vnetid, $vlan) = @path;
+
+                if ($zoneid eq $zone && $vnetid eq $bridge && defined($vlan)) {
+                    my $vlanpath = "/sdn/zones/$zoneid/$vnetid/$vlan";
+                    return 1 if $self->check_any($username, $vlanpath, $privs, 1);
+                }
+            }
+        }
+    }
+
     # repeat check, but fatal
     $self->check_any($username, $path, $privs, 0) if !$noerr;
 
diff --git a/src/test/parser_writer.pl b/src/test/parser_writer.pl
index ea2778e..a809e21 100755
--- a/src/test/parser_writer.pl
+++ b/src/test/parser_writer.pl
@@ -238,24 +238,35 @@ my $default_cfg = {
         vms => {},
         storage => {},
         pools => {},
+        network => {},
     },
     test_pool_members => {
         'id' => 'testpool',
         vms => { 123 => 1, 1234 => 1 },
         storage => { 'local' => 1, 'local-zfs' => 1 },
         pools => {},
+        network => { "vnet/zone1/vnet1" => 1, 'vnet/zone2/vnet2' => 1 },
     },
     test_pool_duplicate_vms => {
         'id' => 'test_duplicate_vms',
         vms => {},
         storage => {},
         pools => {},
+        network => {},
     },
     test_pool_duplicate_storages => {
         'id' => 'test_duplicate_storages',
         vms => {},
         storage => { 'local' => 1, 'local-zfs' => 1 },
         pools => {},
+        network => {},
+    },
+    test_pool_duplicate_networks => {
+        'id' => 'test_duplicate_networks',
+        vms => {},
+        storage => {},
+        pools => {},
+        network => { "vnet/zone1/vnet1" => 1, "vnet/zone2/vnet2" => 1 },
     },
     acl_simple_user => {
         'path' => '/',
@@ -431,12 +442,15 @@ my $default_raw = {
         'test_role_privs_invalid' => 'role:testrole:VM.Invalid,Datastore.Audit,VM.Allocate:',
     },
     pools => {
-        'test_pool_empty' => 'pool:testpool::::',
-        'test_pool_invalid' => 'pool:testpool::non-numeric:inval!d:',
-        'test_pool_members' => 'pool:testpool::123,1234:local,local-zfs:',
-        'test_pool_duplicate_vms' => 'pool:test_duplicate_vms::123,1234::',
-        'test_pool_duplicate_vms_expected' => 'pool:test_duplicate_vms::::',
-        'test_pool_duplicate_storages' => 'pool:test_duplicate_storages:::local,local-zfs:',
+        'test_pool_empty' => 'pool:testpool:::::',
+        'test_pool_invalid' => 'pool:testpool::non-numeric:inval!d::',
+        'test_pool_members' =>
+            'pool:testpool::123,1234:local,local-zfs:vnet/zone1/vnet1,vnet/zone2/vnet2:',
+        'test_pool_duplicate_vms' => 'pool:test_duplicate_vms::123,1234:::',
+        'test_pool_duplicate_vms_expected' => 'pool:test_duplicate_vms:::::',
+        'test_pool_duplicate_storages' => 'pool:test_duplicate_storages:::local,local-zfs::',
+        'test_pool_duplicate_networks' =>
+            'pool:test_duplicate_networks::::vnet/zone1/vnet1,vnet/zone2/vnet2:',
     },
     acl => {
         'acl_simple_user' => 'acl:1:/:test@pam:PVEVMAdmin:',
@@ -696,6 +710,7 @@ my $tests = [
                     $default_cfg->{test_pool_members},
                     $default_cfg->{test_pool_duplicate_vms},
                     $default_cfg->{test_pool_duplicate_storages},
+                    $default_cfg->{test_pool_duplicate_networks},
                 ],
             ),
             vms => default_pool_vms_with([$default_cfg->{test_pool_members}]),
@@ -705,15 +720,37 @@ my $tests = [
             . "\n\n\n"
             . $default_raw->{pools}->{'test_pool_members'} . "\n"
             . $default_raw->{pools}->{'test_pool_duplicate_vms'} . "\n"
-            . $default_raw->{pools}->{'test_pool_duplicate_storages'} . "\n",
+            . $default_raw->{pools}->{'test_pool_duplicate_storages'} . "\n"
+            . $default_raw->{pools}->{'test_pool_duplicate_networks'} . "\n",
         expected_raw => ""
             . $default_raw->{users}->{'root@pam'}
             . "\n\n\n"
+            . $default_raw->{pools}->{'test_pool_duplicate_networks'} . "\n"
             . $default_raw->{pools}->{'test_pool_duplicate_storages'} . "\n"
             . $default_raw->{pools}->{'test_pool_duplicate_vms_expected'} . "\n"
             . $default_raw->{pools}->{'test_pool_members'}
             . "\n\n\n",
     },
+    {
+        name => "pool_format_backward_compatibility",
+        config => {
+            acl_root => default_acls(),
+            users => default_users(),
+            roles => default_roles(),
+            pools => default_pools_with([$default_cfg->{test_pool_empty}]),
+        },
+        raw => ""
+            . $default_raw->{users}->{'root@pam'}
+            . "\n\n\n"
+            # old format: 4 colons
+            . "pool:testpool::::\n\n\n",
+        expected_raw => ""
+            . $default_raw->{users}->{'root@pam'}
+            . "\n\n\n"
+            # new format 5: colons
+            . $default_raw->{pools}->{'test_pool_empty'}
+            . "\n\n\n",
+    },
     {
         name => "acl_simple_user",
         config => {
@@ -1102,7 +1139,7 @@ my $tests = [
             . 'user:test@pam:0:0::::::' . "\n"
             . 'token:test@pam!test:0:0::' . "\n\n"
             . 'group:testgroup:::' . "\n\n"
-            . 'pool:testpool::::' . "\n\n"
+            . 'pool:testpool:::::' . "\n\n"
             . 'role:testrole::' . "\n\n",
     },
 ];
-- 
2.47.3