[pve-guest-common.git] / src / PVE / GuestHelpers.pm

package PVE::GuestHelpers;

use strict;
use warnings;

use PVE::Exception qw(raise_perm_exc);
use PVE::Tools;
use PVE::Storage;

use POSIX qw(strftime);
use Scalar::Util qw(weaken);

use base qw(Exporter);

our @EXPORT_OK = qw(
assert_tag_permissions
get_allowed_tags
safe_boolean_ne
safe_num_ne
safe_string_ne
typesafe_ne
);

# We use a separate lock to block migration while a replication job
# is running.

our $lockdir = '/var/lock/pve-manager';

# safe variable comparison functions

sub safe_num_ne {
    my ($a, $b) = @_;

    return 0 if !defined($a) && !defined($b);
    return 1 if !defined($a);
    return 1 if !defined($b);

    return $a != $b;
}

sub safe_string_ne  {
    my ($a, $b) = @_;

    return 0 if !defined($a) && !defined($b);
    return 1 if !defined($a);
    return 1 if !defined($b);

    return $a ne $b;
}

sub safe_boolean_ne {
    my ($a, $b) = @_;

    # we don't check if value is defined, since undefined
    # is false (so it's a valid boolean)

    # negate both values to normalize and compare
    return !$a != !$b;
}

sub typesafe_ne {
    my ($a, $b, $type) = @_;

    return 0 if !defined($a) && !defined($b);
    return 1 if !defined($a);
    return 1 if !defined($b);

    if ($type eq 'string') {
	return safe_string_ne($a, $b);
    } elsif ($type eq 'number' || $type eq 'integer') {
	return safe_num_ne($a, $b);
    } elsif ($type eq 'boolean') {
	return safe_boolean_ne($a, $b);
    }

    die "internal error: can't compare $a and $b with type $type";
}


sub guest_migration_lock {
    my ($vmid, $timeout, $func, @param) = @_;

    my $lockid = "pve-migrate-$vmid";

    mkdir $lockdir;

    my $res = PVE::Tools::lock_file("$lockdir/$lockid", $timeout, $func, @param);
    die $@ if $@;

    return $res;
}

sub check_hookscript {
    my ($volid, $storecfg) = @_;

    $storecfg = PVE::Storage::config() if !defined($storecfg);
    my ($path, undef, $type) = PVE::Storage::path($storecfg, $volid);

    die "'$volid' is not in the snippets directory\n"
	if $type ne 'snippets';

    die "script '$volid' does not exist\n"
	if ! -f $path;

    die "script '$volid' is not executable\n"
	if ! -x $path;

    return $path;
}

sub exec_hookscript {
    my ($conf, $vmid, $phase, $stop_on_error) = @_;

    return if !$conf->{hookscript};

    eval {
	my $hookscript = check_hookscript($conf->{hookscript});
	die $@ if $@;

	PVE::Tools::run_command([$hookscript, $vmid, $phase]);
    };
    if (my $err = $@) {
	my $errmsg = "hookscript error for $vmid on $phase: $err\n";
	die $errmsg if ($stop_on_error);
	warn $errmsg;
    }
}

# takes a snapshot list (e.g., qm/pct snapshot_list API call result) and
# prints it out in a nice tree sorted by age. Can cope with multiple roots
sub print_snapshot_tree {
    my ($snapshot_list) = @_;

    my $snapshots = { map { $_->{name} => $_ } @$snapshot_list };

    my @roots;
    foreach my $e (@$snapshot_list) {
	my $parent;
	if (($parent = $e->{parent}) && defined $snapshots->{$parent}) {
	    push @{$snapshots->{$parent}->{children}}, $e->{name};
	} else {
	    push @roots, $e->{name};
	}
    }

    # sort the elements by snaptime - with "current" (no snaptime) highest
    my $snaptimesort = sub {
	return +1 if !defined $snapshots->{$a}->{snaptime};
	return -1 if !defined $snapshots->{$b}->{snaptime};
	return $snapshots->{$a}->{snaptime} <=> $snapshots->{$b}->{snaptime};
    };

    # recursion function for displaying the tree
    my $snapshottree_weak;
    $snapshottree_weak = sub {
	my ($prefix, $root, $snapshots) = @_;
	my $e = $snapshots->{$root};

	my $description = $e->{description} || 'no-description';
	($description) = $description =~ m/(.*)$/m;

	my $timestring = "";
	if (defined $e->{snaptime}) {
	    $timestring = strftime("%F %H:%M:%S", localtime($e->{snaptime}));
	}

	my $len = 30 - length($prefix); # for aligning the description
	$len = 0 if $len < 0;
	printf("%s %-${len}s %-23s %s\n", $prefix, $root, $timestring, $description);

	if ($e->{children}) {
	    $prefix = " $prefix";
	    foreach my $child (sort $snaptimesort @{$e->{children}}) {
		$snapshottree_weak->($prefix, $child, $snapshots);
	    }
	}
    };
    my $snapshottree = $snapshottree_weak;
    weaken($snapshottree_weak);

    foreach my $root (sort $snaptimesort @roots) {
	$snapshottree->('`->', $root, $snapshots);
    }
}

sub format_pending {
    my ($data) = @_;
    foreach my $item (sort { $a->{key} cmp $b->{key}} @$data) {
	my $k = $item->{key};
	next if $k eq 'digest';
	my $v = $item->{value};
	my $p = $item->{pending};
	if ($k eq 'description') {
	    $v = PVE::Tools::encode_text($v) if defined($v);
	    $p = PVE::Tools::encode_text($p) if defined($p);
	}
	if (defined($v)) {
	    if ($item->{delete}) {
		print "del $k: $v\n";
	    } elsif (defined($p)) {
		print "cur $k: $v\n";
		print "new $k: $p\n";
	    } else {
		print "cur $k: $v\n";
	    }
	} elsif (defined($p)) {
	    print "new $k: $p\n";
	}
    }
}

# returns the config as an array of hashes, each hash can have the following keys:
#  key: the config property name, non-optional
#  value: the current value in effect - if any
#  pending: a new, still pending, value - if any
#  delete: when deletions are pending, this is set to either 2 (force) or 1 (graceful)
sub config_with_pending_array {
    my ($conf, $pending_delete_hash) = @_;

    my $pending = delete $conf->{pending};
    # we don't care for snapshots in pending and it makes our loops throw up
    delete $conf->{snapshots};

    my $res = [];
    foreach my $opt (keys %$conf) {
	next if ref($conf->{$opt}); # e.g., "raw" lxc.* keys are added as array ref

	my $item = {
	    key => $opt,
	    value => $conf->{$opt},
	};
	$item->{pending} = delete $pending->{$opt} if defined($pending->{$opt});
	my $delete = delete $pending_delete_hash->{$opt};
	$item->{delete} = $delete->{force} ? 2 : 1 if defined($delete);

	push @$res, $item;
    }

    foreach my $opt (keys %$pending) {
	next if $opt eq 'delete';
	push @$res, {
	    key => $opt,
	    pending => $pending->{$opt},
	};
    }

    while (my ($opt, $force) = each %$pending_delete_hash) {
	push @$res, {
	    key => $opt,
	    delete => $force ? 2 : 1,
	};
    }

    return $res;
}

# returns the allowed tags for the given user
# in scalar context, returns the list of allowed tags that exist
# in list context, returns a tuple of allowed tags, privileged tags, and if freeform is enabled
#
# first parameter is a bool if the user is 'privileged' (normally Sys.Modify on /)
# second parameter is a closure which takes the vmid. should check if the user can see the vm tags
sub get_allowed_tags {
    my ($rpcenv, $user, $privileged_user) = @_;

    $privileged_user //= ($rpcenv->check($user, '/', ['Sys.Modify'], 1) // 0);

    my $dc = PVE::Cluster::cfs_read_file('datacenter.cfg');

    my $allowed_tags = {};
    my $privileged_tags = {};
    if (my $tags = $dc->{'registered-tags'}) {
	$privileged_tags->{$_} = 1 for $tags->@*;
    }
    my $user_tag_privs = $dc->{'user-tag-access'} // {};
    my $user_allow = $user_tag_privs->{'user-allow'} // 'free';
    my $freeform = $user_allow eq 'free';

    if ($user_allow ne 'none' || $privileged_user) {
	$allowed_tags->{$_} = 1 for ($user_tag_privs->{'user-allow-list'} // [])->@*;
    }

    if ($user_allow eq 'free' || $user_allow eq 'existing' || $privileged_user) {
	my $props = PVE::Cluster::get_guest_config_properties(['tags']);
	for my $vmid (keys $props->%*) {
	    next if !$privileged_user && !$rpcenv->check_vm_perm($user, $vmid, undef, ['VM.Audit'], 0, 1);
	    $allowed_tags->{$_} = 1 for PVE::Tools::split_list($props->{$vmid}->{tags});
	}
    }

    if ($privileged_user) {
	$allowed_tags->{$_} = 1 for keys $privileged_tags->%*;
    } else {
	delete $allowed_tags->{$_} for keys $privileged_tags->%*;
    }

    return wantarray ? ($allowed_tags, $privileged_tags, $freeform) : $allowed_tags;
}

# checks the permissions for setting/updating/removing tags for guests
# tagopt_old and tagopt_new expect the tags as they are in the config
#
# either returns gracefully or raises a permission exception
sub assert_tag_permissions {
    my ($vmid, $tagopt_old, $tagopt_new, $rpcenv, $authuser) = @_;

    my $allowed_tags;
    my $privileged_tags;
    my $freeform;
    my $privileged_user = $rpcenv->check($authuser, '/', ['Sys.Modify'], 1) // 0;

    $rpcenv->check_vm_perm($authuser, $vmid, undef, ['VM.Config.Options']);

    my $check_single_tag = sub {
	my ($tag) = @_;
	return if $privileged_user;

	if (!defined($allowed_tags) && !defined($privileged_tags) && !defined($freeform)) {
	    ($allowed_tags, $privileged_tags, $freeform) = get_allowed_tags(
		$rpcenv,
		$authuser,
		$privileged_user,
	    );
	}

	if ((!$allowed_tags->{$tag} && !$freeform) || $privileged_tags->{$tag}) {
	    raise_perm_exc("/, Sys.Modify for modifying tag '$tag'");
	}

	return;
    };

    my $old_tags = {};
    my $new_tags = {};
    my $all_tags = {};

    $all_tags->{$_} = $old_tags->{$_} += 1 for PVE::Tools::split_list($tagopt_old // '');
    $all_tags->{$_} = $new_tags->{$_} += 1 for PVE::Tools::split_list($tagopt_new // '');

    for my $tag (keys $all_tags->%*) {
	next if ($new_tags->{$tag} // 0) == ($old_tags->{$tag} // 0);
	$check_single_tag->($tag);
    }
}

1;
Commit	Line	Data
94d526d7 DM	1	package PVE::GuestHelpers;
	2
	3	use strict;
	4	use warnings;
	5
2b00f623	6	use PVE::Exception qw(raise_perm_exc);
94d526d7	7	use PVE::Tools;
3acb4e74	8	use PVE::Storage;
94d526d7	9
725dcadb	10	use POSIX qw(strftime);
727080ed	11	use Scalar::Util qw(weaken);
725dcadb	12
b2b16cee DC	13	use base qw(Exporter);
b2b16cee DC	14
2b00f623 DC	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	);
24d90d8d	23
94d526d7 DM	24	# We use a separate lock to block migration while a replication job
	25	# is running.
	26
7919c482 WB	27	our $lockdir = '/var/lock/pve-manager';
7919c482 WB	28
24d90d8d OB	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
94d526d7 DM	80	sub guest_migration_lock {
	81	my ($vmid, $timeout, $func, @param) = @_;
	82
	83	my $lockid = "pve-migrate-$vmid";
94d526d7 DM	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
3acb4e74 DC	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
fb73d112	102	die "script '$volid' does not exist\n"
3acb4e74 DC	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};
3acb4e74 DC	115
3acb4e74 DC	116	eval {
1c9da8ac TL	117	my $hookscript = check_hookscript($conf->{hookscript});
	118	die $@ if $@;
	119
3acb4e74 DC	120	PVE::Tools::run_command([$hookscript, $vmid, $phase]);
3acb4e74 DC	121	};
3acb4e74 DC	122	if (my $err = $@) {
3acb4e74 DC	123	my $errmsg = "hookscript error for $vmid on $phase: $err\n";
1c9da8ac TL	124	die $errmsg if ($stop_on_error);
1c9da8ac TL	125	warn $errmsg;
3acb4e74 DC	126	}
	127	}
	128
5ee5f887 TL	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) = @_;
725dcadb	133
5ee5f887	134	my $snapshots = { map { $_->{name} => $_ } @$snapshot_list };
725dcadb OB	135
725dcadb OB	136	my @roots;
5ee5f887	137	foreach my $e (@$snapshot_list) {
725dcadb OB	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
727080ed WB	154	my $snapshottree_weak;
727080ed WB	155	$snapshottree_weak = sub {
725dcadb OB	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
9fca8f9d	168	$len = 0 if $len < 0;
725dcadb OB	169	printf("%s %-${len}s %-23s %s\n", $prefix, $root, $timestring, $description);
	170
	171	if ($e->{children}) {
e6e15500	172	$prefix = " $prefix";
725dcadb	173	foreach my $child (sort $snaptimesort @{$e->{children}}) {
727080ed	174	$snapshottree_weak->($prefix, $child, $snapshots);
725dcadb OB	175	}
	176	}
	177	};
727080ed WB	178	my $snapshottree = $snapshottree_weak;
727080ed WB	179	weaken($snapshottree_weak);
725dcadb OB	180
	181	foreach my $root (sort $snaptimesort @roots) {
	182	$snapshottree->('`->', $root, $snapshots);
	183	}
	184	}
	185
bd240228 OB	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
55001030	212	# returns the config as an array of hashes, each hash can have the following keys:
daf8fca5 TL	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)
55001030	217	sub config_with_pending_array {
15144481 OB	218	my ($conf, $pending_delete_hash) = @_;
15144481 OB	219
daf8fca5 TL	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};
15144481	223
daf8fca5	224	my $res = [];
15144481	225	foreach my $opt (keys %$conf) {
07c587d8	226	next if ref($conf->{$opt}); # e.g., "raw" lxc.* keys are added as array ref
dd59a7ca	227
daf8fca5 TL	228	my $item = {
	229	key => $opt,
	230	value => $conf->{$opt},
	231	};
301b375b	232	$item->{pending} = delete $pending->{$opt} if defined($pending->{$opt});
daf8fca5 TL	233	my $delete = delete $pending_delete_hash->{$opt};
daf8fca5 TL	234	$item->{delete} = $delete->{force} ? 2 : 1 if defined($delete);
15144481 OB	235
	236	push @$res, $item;
	237	}
	238
daf8fca5	239	foreach my $opt (keys %$pending) {
15144481	240	next if $opt eq 'delete';
daf8fca5 TL	241	push @$res, {
	242	key => $opt,
	243	pending => $pending->{$opt},
	244	};
15144481 OB	245	}
	246
	247	while (my ($opt, $force) = each %$pending_delete_hash) {
daf8fca5 TL	248	push @$res, {
	249	key => $opt,
	250	delete => $force ? 2 : 1,
	251	};
15144481 OB	252	}
	253
	254	return $res;
	255	}
	256
2b00f623 DC	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 $dc = PVE::Cluster::cfs_read_file('datacenter.cfg');
	269
	270	my $allowed_tags = {};
	271	my $privileged_tags = {};
	272	if (my $tags = $dc->{'registered-tags'}) {
	273	$privileged_tags->{$_} = 1 for $tags->@*;
	274	}
	275	my $user_tag_privs = $dc->{'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 PVE::Tools::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	my $allowed_tags;
	308	my $privileged_tags;
	309	my $freeform;
	310	my $privileged_user = $rpcenv->check($authuser, '/', ['Sys.Modify'], 1) // 0;
	311
	312	$rpcenv->check_vm_perm($authuser, $vmid, undef, ['VM.Config.Options']);
	313
	314	my $check_single_tag = sub {
	315	my ($tag) = @_;
	316	return if $privileged_user;
	317
	318	if (!defined($allowed_tags) && !defined($privileged_tags) && !defined($freeform)) {
	319	($allowed_tags, $privileged_tags, $freeform) = get_allowed_tags(
	320	$rpcenv,
321	$authuser,
322	$privileged_user,
323	);
324	}
325
326	if ((!$allowed_tags->{$tag} && !$freeform) \|\| $privileged_tags->{$tag}) {
327	raise_perm_exc("/, Sys.Modify for modifying tag '$tag'");
328	}
329
330	return;
331	};
332
333	my $old_tags = {};
334	my $new_tags = {};
335	my $all_tags = {};
336
337	$all_tags->{$_} = $old_tags->{$_} += 1 for PVE::Tools::split_list($tagopt_old // '');
338	$all_tags->{$_} = $new_tags->{$_} += 1 for PVE::Tools::split_list($tagopt_new // '');
339
340	for my $tag (keys $all_tags->%*) {
341	next if ($new_tags->{$tag} // 0) == ($old_tags->{$tag} // 0);
342	$check_single_tag->($tag);
343	}
344	}
345
94d526d7	346	1;