src/PVE/GuestHelpers.pm

   1 package PVE::GuestHelpers;
   2
   3 use strict;
   4 use warnings;
   5
   6 use PVE::Exception qw(raise_perm_exc);
   7 use PVE::Tools qw(split_list);
   8 use PVE::Storage;
   9
  10 use POSIX qw(strftime);
  11 use Scalar::Util qw(weaken);
  12
  13 use base qw(Exporter);
  14
  15 our @EXPORT_OK = qw(
  16 assert_tag_permissions
  17 get_allowed_tags
  18 safe_boolean_ne
  19 safe_num_ne
  20 safe_string_ne
  21 typesafe_ne
  22 );
  23
  24 # We use a separate lock to block migration while a replication job
  25 # is running.
  26
  27 our $lockdir = '/var/lock/pve-manager';
  28
  29 # safe variable comparison functions
  30
  31 sub safe_num_ne {
  32     my ($a, $b) = @_;
  33
  34     return 0 if !defined($a) && !defined($b);
  35     return 1 if !defined($a);
  36     return 1 if !defined($b);
  37
  38     return $a != $b;
  39 }
  40
  41 sub safe_string_ne  {
  42     my ($a, $b) = @_;
  43
  44     return 0 if !defined($a) && !defined($b);
  45     return 1 if !defined($a);
  46     return 1 if !defined($b);
  47
  48     return $a ne $b;
  49 }
  50
  51 sub safe_boolean_ne {
  52     my ($a, $b) = @_;
  53
  54     # we don't check if value is defined, since undefined
  55     # is false (so it's a valid boolean)
  56
  57     # negate both values to normalize and compare
  58     return !$a != !$b;
  59 }
  60
  61 sub typesafe_ne {
  62     my ($a, $b, $type) = @_;
  63
  64     return 0 if !defined($a) && !defined($b);
  65     return 1 if !defined($a);
  66     return 1 if !defined($b);
  67
  68     if ($type eq 'string') {
  69         return safe_string_ne($a, $b);
  70     } elsif ($type eq 'number' || $type eq 'integer') {
  71         return safe_num_ne($a, $b);
  72     } elsif ($type eq 'boolean') {
  73         return safe_boolean_ne($a, $b);
  74     }
  75
  76     die "internal error: can't compare $a and $b with type $type";
  77 }
  78
  79
  80 sub guest_migration_lock {
  81     my ($vmid, $timeout, $func, @param) = @_;
  82
  83     my $lockid = "pve-migrate-$vmid";
  84
  85     mkdir $lockdir;
  86
  87     my $res = PVE::Tools::lock_file("$lockdir/$lockid", $timeout, $func, @param);
  88     die $@ if $@;
  89
  90     return $res;
  91 }
  92
  93 sub check_hookscript {
  94     my ($volid, $storecfg) = @_;
  95
  96     $storecfg = PVE::Storage::config() if !defined($storecfg);
  97     my ($path, undef, $type) = PVE::Storage::path($storecfg, $volid);
  98
  99     die "'$volid' is not in the snippets directory\n"
 100         if $type ne 'snippets';
 101
 102     die "script '$volid' does not exist\n"
 103         if ! -f $path;
 104
 105     die "script '$volid' is not executable\n"
 106         if ! -x $path;
 107
 108     return $path;
 109 }
 110
 111 sub exec_hookscript {
 112     my ($conf, $vmid, $phase, $stop_on_error) = @_;
 113
 114     return if !$conf->{hookscript};
 115
 116     eval {
 117         my $hookscript = check_hookscript($conf->{hookscript});
 118         die $@ if $@;
 119
 120         PVE::Tools::run_command([$hookscript, $vmid, $phase]);
 121     };
 122     if (my $err = $@) {
 123         my $errmsg = "hookscript error for $vmid on $phase: $err\n";
 124         die $errmsg if ($stop_on_error);
 125         warn $errmsg;
 126     }
 127 }
 128
 129 # takes a snapshot list (e.g., qm/pct snapshot_list API call result) and
 130 # prints it out in a nice tree sorted by age. Can cope with multiple roots
 131 sub print_snapshot_tree {
 132     my ($snapshot_list) = @_;
 133
 134     my $snapshots = { map { $_->{name} => $_ } @$snapshot_list };
 135
 136     my @roots;
 137     foreach my $e (@$snapshot_list) {
 138         my $parent;
 139         if (($parent = $e->{parent}) && defined $snapshots->{$parent}) {
 140             push @{$snapshots->{$parent}->{children}}, $e->{name};
 141         } else {
 142             push @roots, $e->{name};
 143         }
 144     }
 145
 146     # sort the elements by snaptime - with "current" (no snaptime) highest
 147     my $snaptimesort = sub {
 148         return +1 if !defined $snapshots->{$a}->{snaptime};
 149         return -1 if !defined $snapshots->{$b}->{snaptime};
 150         return $snapshots->{$a}->{snaptime} <=> $snapshots->{$b}->{snaptime};
 151     };
 152
 153     # recursion function for displaying the tree
 154     my $snapshottree_weak;
 155     $snapshottree_weak = sub {
 156         my ($prefix, $root, $snapshots) = @_;
 157         my $e = $snapshots->{$root};
 158
 159         my $description = $e->{description} || 'no-description';
 160         ($description) = $description =~ m/(.*)$/m;
 161
 162         my $timestring = "";
 163         if (defined $e->{snaptime}) {
 164             $timestring = strftime("%F %H:%M:%S", localtime($e->{snaptime}));
 165         }
 166
 167         my $len = 30 - length($prefix); # for aligning the description
 168         $len = 0 if $len < 0;
 169         printf("%s %-${len}s %-23s %s\n", $prefix, $root, $timestring, $description);
 170
 171         if ($e->{children}) {
 172             $prefix = " $prefix";
 173             foreach my $child (sort $snaptimesort @{$e->{children}}) {
 174                 $snapshottree_weak->($prefix, $child, $snapshots);
 175             }
 176         }
 177     };
 178     my $snapshottree = $snapshottree_weak;
 179     weaken($snapshottree_weak);
 180
 181     foreach my $root (sort $snaptimesort @roots) {
 182         $snapshottree->('`->', $root, $snapshots);
 183     }
 184 }
 185
 186 sub format_pending {
 187     my ($data) = @_;
 188     foreach my $item (sort { $a->{key} cmp $b->{key}} @$data) {
 189         my $k = $item->{key};
 190         next if $k eq 'digest';
 191         my $v = $item->{value};
 192         my $p = $item->{pending};
 193         if ($k eq 'description') {
 194             $v = PVE::Tools::encode_text($v) if defined($v);
 195             $p = PVE::Tools::encode_text($p) if defined($p);
 196         }
 197         if (defined($v)) {
 198             if ($item->{delete}) {
 199                 print "del $k: $v\n";
 200             } elsif (defined($p)) {
 201                 print "cur $k: $v\n";
 202                 print "new $k: $p\n";
 203             } else {
 204                 print "cur $k: $v\n";
 205             }
 206         } elsif (defined($p)) {
 207             print "new $k: $p\n";
 208         }
 209     }
 210 }
 211
 212 # returns the config as an array of hashes, each hash can have the following keys:
 213 #  key: the config property name, non-optional
 214 #  value: the current value in effect - if any
 215 #  pending: a new, still pending, value - if any
 216 #  delete: when deletions are pending, this is set to either 2 (force) or 1 (graceful)
 217 sub config_with_pending_array {
 218     my ($conf, $pending_delete_hash) = @_;
 219
 220     my $pending = delete $conf->{pending};
 221     # we don't care for snapshots in pending and it makes our loops throw up
 222     delete $conf->{snapshots};
 223
 224     my $res = [];
 225     foreach my $opt (keys %$conf) {
 226         next if ref($conf->{$opt}); # e.g., "raw" lxc.* keys are added as array ref
 227
 228         my $item = {
 229             key => $opt,
 230             value => $conf->{$opt},
 231         };
 232         $item->{pending} = delete $pending->{$opt} if defined($pending->{$opt});
 233         my $delete = delete $pending_delete_hash->{$opt};
 234         $item->{delete} = $delete->{force} ? 2 : 1 if defined($delete);
 235
 236         push @$res, $item;
 237     }
 238
 239     foreach my $opt (keys %$pending) {
 240         next if $opt eq 'delete';
 241         push @$res, {
 242             key => $opt,
 243             pending => $pending->{$opt},
 244         };
 245     }
 246
 247     while (my ($opt, $force) = each %$pending_delete_hash) {
 248         push @$res, {
 249             key => $opt,
 250             delete => $force ? 2 : 1,
 251         };
 252     }
 253
 254     return $res;
 255 }
 256
 257 # returns the allowed tags for the given user
 258 # in scalar context, returns the list of allowed tags that exist
 259 # in list context, returns a tuple of allowed tags, privileged tags, and if freeform is enabled
 260 #
 261 # first parameter is a bool if the user is 'privileged' (normally Sys.Modify on /)
 262 # second parameter is a closure which takes the vmid. should check if the user can see the vm tags
 263 sub get_allowed_tags {
 264     my ($rpcenv, $user, $privileged_user) = @_;
 265
 266     $privileged_user //= ($rpcenv->check($user, '/', ['Sys.Modify'], 1) // 0);
 267
 268     my $datacenter_config = PVE::Cluster::cfs_read_file('datacenter.cfg');
 269
 270     my $allowed_tags = {};
 271     my $privileged_tags = {};
 272     if (my $tags = $datacenter_config->{'registered-tags'}) {
 273         $privileged_tags->{$_} = 1 for $tags->@*;
 274     }
 275     my $user_tag_privs = $datacenter_config->{'user-tag-access'} // {};
 276     my $user_allow = $user_tag_privs->{'user-allow'} // 'free';
 277     my $freeform = $user_allow eq 'free';
 278
 279     if ($user_allow ne 'none' || $privileged_user) {
 280         $allowed_tags->{$_} = 1 for ($user_tag_privs->{'user-allow-list'} // [])->@*;
 281     }
 282
 283     if ($user_allow eq 'free' || $user_allow eq 'existing' || $privileged_user) {
 284         my $props = PVE::Cluster::get_guest_config_properties(['tags']);
 285         for my $vmid (keys $props->%*) {
 286             next if !$privileged_user && !$rpcenv->check_vm_perm($user, $vmid, undef, ['VM.Audit'], 0, 1);
 287             $allowed_tags->{$_} = 1 for split_list($props->{$vmid}->{tags});
 288         }
 289     }
 290
 291     if ($privileged_user) {
 292         $allowed_tags->{$_} = 1 for keys $privileged_tags->%*;
 293     } else {
 294         delete $allowed_tags->{$_} for keys $privileged_tags->%*;
 295     }
 296
 297     return wantarray ? ($allowed_tags, $privileged_tags, $freeform) : $allowed_tags;
 298 }
 299
 300 # checks the permissions for setting/updating/removing tags for guests
 301 # tagopt_old and tagopt_new expect the tags as they are in the config
 302 #
 303 # either returns gracefully or raises a permission exception
 304 sub assert_tag_permissions {
 305     my ($vmid, $tagopt_old, $tagopt_new, $rpcenv, $authuser) = @_;
 306
 307     $rpcenv->check_vm_perm($authuser, $vmid, undef, ['VM.Config.Options']);
 308
 309     my $privileged_user = $rpcenv->check($authuser, '/', ['Sys.Modify'], 1) // 0;
 310
 311     my ($allowed_tags, $privileged_tags, $freeform);
 312     my $check_single_tag = sub {
 313         my ($tag) = @_;
 314         return if $privileged_user;
 315
 316         if (!defined($allowed_tags // $privileged_tags // $freeform)) { # cache
 317             ($allowed_tags, $privileged_tags, $freeform) = get_allowed_tags($rpcenv, $authuser, $privileged_user);
 318         }
 319
 320         if ((!$allowed_tags->{$tag} && !$freeform) || $privileged_tags->{$tag}) {
 321             raise_perm_exc("/, Sys.Modify for modifying tag '$tag'");
 322         }
 323
 324         return;
 325     };
 326
 327     my ($old_tags, $new_tags, $all_tags) = ({}, {}, {});
 328
 329     $all_tags->{$_} = $old_tags->{$_} += 1 for split_list($tagopt_old // '');
 330     $all_tags->{$_} = $new_tags->{$_} += 1 for split_list($tagopt_new // '');
 331
 332     for my $tag (keys $all_tags->%*) {
 333         next if ($new_tags->{$tag} // 0) == ($old_tags->{$tag} // 0);
 334         $check_single_tag->($tag);
 335     }
 336 }
 337
 338 sub get_unique_tags {
 339     my ($tags, $no_join_result) = @_;
 340
 341     $tags = [ split_list($tags // '') ] if ref($tags) ne 'ARRAY';
 342     return !$no_join_result ? '': [] if !scalar($tags->@*);
 343
 344     my $datacenter_config = PVE::Cluster::cfs_read_file('datacenter.cfg');
 345     my $tag_style_config = $datacenter_config->{'tag-style'} // {};
 346     my $case_sensitive = !!$tag_style_config->{'case-sensitive'};
 347
 348     my $seen_tags = {};
 349     my $res = [];
 350     if (!defined($tag_style_config->{ordering}) || $tag_style_config->{ordering} ne 'config') {
 351         for my $tag ( sort { $case_sensitive ? $a cmp $b : lc($a) cmp lc($b) } $tags->@*) {
 352             $tag = lc($tag) if !$case_sensitive;
 353             next if $seen_tags->{$tag};
 354             $seen_tags->{$tag} = 1;
 355             push @$res, $tag;
 356         }
 357     } else {
 358         for my $tag ($tags->@*) {
 359             $tag = lc($tag) if !$case_sensitive;
 360             next if $seen_tags->{$tag};
 361             $seen_tags->{$tag} = 1;
 362             push @$res, $tag;
 363         }
 364     }
 365
 366     return !$no_join_result ? join(';', $res->@*) : $res;
 367 }
 368
 369 1;