X-Git-Url: https://git.proxmox.com/?a=blobdiff_plain;f=src%2FPVE%2FTools.pm;h=d5373a4246062887bd778f35f4d2ac9cf2bb8bd1;hb=refs%2Fheads%2Fmaster;hp=d9c69e3d803683460ac7b7c95981e3d9d1e8e306;hpb=cb9db10c1a9855cf40ff13e81f9dd97d6a9b2698;p=pve-common.git diff --git a/src/PVE/Tools.pm b/src/PVE/Tools.pm index d9c69e3..766c809 100644 --- a/src/PVE/Tools.pm +++ b/src/PVE/Tools.pm @@ -2,29 +2,32 @@ package PVE::Tools; use strict; use warnings; -use POSIX qw(EINTR EEXIST EOPNOTSUPP); -use IO::Socket::IP; -use Socket qw(AF_INET AF_INET6 AI_ALL AI_V4MAPPED AI_CANONNAME SOCK_DGRAM - IPPROTO_TCP); -use IO::Select; + +use Date::Format qw(time2str); +use Digest::MD5; +use Digest::SHA; +use Encode; +use Fcntl qw(:DEFAULT :flock); use File::Basename; use File::Path qw(make_path); use Filesys::Df (); # don't overwrite our df() -use IO::Pipe; -use IO::File; use IO::Dir; +use IO::File; use IO::Handle; +use IO::Pipe; +use IO::Select; +use IO::Socket::IP; use IPC::Open3; -use Fcntl qw(:DEFAULT :flock); -use base 'Exporter'; -use URI::Escape; -use Encode; -use Digest::SHA; use JSON; -use Text::ParseWords; +use POSIX qw(EINTR EEXIST EOPNOTSUPP); +use Scalar::Util 'weaken'; +use Socket qw(AF_INET AF_INET6 AI_ALL AI_V4MAPPED AI_CANONNAME SOCK_DGRAM IPPROTO_TCP); use String::ShellQuote; +use Text::ParseWords; use Time::HiRes qw(usleep gettimeofday tv_interval alarm); -use Scalar::Util 'weaken'; +use URI::Escape; +use base 'Exporter'; + use PVE::Syscall; # avoid warning when parsing long hex values with hex() @@ -46,6 +49,7 @@ template_replace safe_print trim extract_param +extract_sensitive_params file_copy get_host_arch O_PATH @@ -58,6 +62,20 @@ CLONE_NEWIPC CLONE_NEWUSER CLONE_NEWPID CLONE_NEWNET +MS_RDONLY +MS_NOSUID +MS_NODEV +MS_NOEXEC +MS_SYNCHRONOUS +MS_REMOUNT +MS_MANDLOCK +MS_DIRSYNC +MS_NOSYMFOLLOW +MS_NOATIME +MS_NODIRATIME +MS_BIND +MS_MOVE +MS_REC ); my $pvelogdir = "/var/log/pve"; @@ -84,6 +102,9 @@ our $IPV6RE = "(?:" . our $IPRE = "(?:$IPV4RE|$IPV6RE)"; +our $EMAIL_USER_RE = qr/[\w\+\-\~]+(\.[\w\+\-\~]+)*/; +our $EMAIL_RE = qr/$EMAIL_USER_RE@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*/; + use constant {CLONE_NEWNS => 0x00020000, CLONE_NEWUTS => 0x04000000, CLONE_NEWIPC => 0x08000000, @@ -92,11 +113,34 @@ use constant {CLONE_NEWNS => 0x00020000, CLONE_NEWNET => 0x40000000}; use constant {O_PATH => 0x00200000, - O_TMPFILE => 0x00410000}; # This includes O_DIRECTORY + O_CLOEXEC => 0x00080000, + O_TMPFILE => 0x00400000 | O_DIRECTORY}; use constant {AT_EMPTY_PATH => 0x1000, AT_FDCWD => -100}; +# from +use constant {RENAME_NOREPLACE => (1 << 0), + RENAME_EXCHANGE => (1 << 1), + RENAME_WHITEOUT => (1 << 2)}; + +use constant { + MS_RDONLY => (1), + MS_NOSUID => (1 << 1), + MS_NODEV => (1 << 2), + MS_NOEXEC => (1 << 3), + MS_SYNCHRONOUS => (1 << 4), + MS_REMOUNT => (1 << 5), + MS_MANDLOCK => (1 << 6), + MS_DIRSYNC => (1 << 7), + MS_NOSYMFOLLOW => (1 << 8), + MS_NOATIME => (1 << 10), + MS_NODIRATIME => (1 << 11), + MS_BIND => (1 << 12), + MS_MOVE => (1 << 13), + MS_REC => (1 << 14), +}; + sub run_with_timeout { my ($timeout, $code, @param) = @_; @@ -105,11 +149,12 @@ sub run_with_timeout { my $prev_alarm = alarm 0; # suspend outer alarm early my $sigcount = 0; + my $got_timeout = 0; my $res; eval { - local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; }; + local $SIG{ALRM} = sub { $sigcount++; $got_timeout = 1; die "got timeout\n"; }; local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" }; local $SIG{__DIE__}; # see SA bug 4631 @@ -129,9 +174,10 @@ sub run_with_timeout { # this shouldn't happen anymore? die "unknown error" if $sigcount && !$err; # seems to happen sometimes - die $err if $err; + # assume that user handles timeout err if called in list context + die $err if $err && (!wantarray || !$got_timeout); - return $res; + return wantarray ? ($res, $got_timeout) : $res; } # flock: we use one file handle per process, so lock file @@ -223,7 +269,7 @@ sub lock_file { } sub file_set_contents { - my ($filename, $data, $perm) = @_; + my ($filename, $data, $perm, $force_utf8) = @_; $perm = 0644 if !defined($perm); @@ -238,6 +284,9 @@ sub file_set_contents { } } die "unable to open file '$tmpname' - $!\n" if !$fh; + + binmode($fh, ":encoding(UTF-8)") if $force_utf8; + die "unable to write '$tmpname' - $!\n" unless print $fh $data; die "closing file '$tmpname' failed - $!\n" unless close $fh; }; @@ -278,7 +327,10 @@ sub file_read_firstline { my ($filename) = @_; my $fh = IO::File->new ($filename, "r"); - return undef if !$fh; + if (!$fh) { + return undef if $! == POSIX::ENOENT; + die "file '$filename' exists but open for reading failed - $!\n"; + } my $res = <$fh>; chomp $res if $res; $fh->close; @@ -289,7 +341,7 @@ sub safe_read_from { my ($fh, $max, $oneline, $filename) = @_; # pmxcfs file size limit - $max = 512*1024 if !$max; + $max = 1024 * 1024 if !$max; my $subject = defined($filename) ? "file '$filename'" : 'input'; @@ -441,13 +493,12 @@ sub run_command { $pid = open3($writer, $reader, $error, @$cmd) || die $!; - # if we pipe fron STDIN, open3 closes STDIN, so we we - # a perl warning "Filehandle STDIN reopened as GENXYZ .. " - # as soon as we open a new file. + # if we pipe fron STDIN, open3 closes STDIN, so we get a perl warning like + # "Filehandle STDIN reopened as GENXYZ .. " as soon as we open a new file. # to avoid that we open /dev/null if (!ref($writer) && !defined(fileno(STDIN))) { POSIX::close(0); - open(STDIN, "new(); $select->add($reader) if ref($reader); $select->add($error); @@ -497,7 +548,7 @@ sub run_command { if ($h eq $reader) { if ($outfunc || $logfunc) { eval { - while ($buf =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//) { + while ($buf =~ s/^([^\010\r\n]*)(?:\n|(?:\010)+|\r\n?)//) { my $line = $outlog . $1; $outlog = ''; &$outfunc($line) if $outfunc; @@ -518,7 +569,7 @@ sub run_command { } elsif ($h eq $error) { if ($errfunc || $logfunc) { eval { - while ($buf =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) { + while ($buf =~ s/^([^\010\r\n]*)(?:\n|(?:\010)+|\r\n?)//) { my $line = $errlog . $1; $errlog = ''; &$errfunc($line) if $errfunc; @@ -563,7 +614,7 @@ sub run_command { } } - alarm(0); + alarm(0); }; my $err = $@; @@ -804,6 +855,28 @@ sub extract_param { return $res; } +# For extracting sensitive keys (e.g. password), to avoid writing them to www-data owned configs +sub extract_sensitive_params :prototype($$$) { + my ($param, $sensitive_list, $delete_list) = @_; + + my %delete = map { $_ => 1 } ($delete_list || [])->@*; + + my $sensitive = {}; + for my $opt (@$sensitive_list) { + # handle deletions as explicitly setting `undef`, so subs which only have $param but not + # $delete_list available can recognize them. Afterwards new values may override. + if (exists($delete{$opt})) { + $sensitive->{$opt} = undef; + } + + if (defined(my $value = extract_param($param, $opt))) { + $sensitive->{$opt} = $value; + } + } + + return $sensitive; +} + # Note: we use this to wait until vncterm/spiceterm is ready sub wait_for_vnc_port { my ($port, $family, $timeout) = @_; @@ -978,9 +1051,16 @@ sub run_fork_with_timeout { $res = $child_res->{result}; $error = $child_res->{error}; }; + + my $got_timeout = 0; + my $wantarray = wantarray; # so it can be queried inside eval eval { if (defined($timeout)) { - run_with_timeout($timeout, $readvalues); + if ($wantarray) { + (undef, $got_timeout) = run_with_timeout($timeout, $readvalues); + } else { + run_with_timeout($timeout, $readvalues); + } } else { $readvalues->(); } @@ -988,13 +1068,14 @@ sub run_fork_with_timeout { warn $@ if $@; $pipe_out->close(); kill('KILL', $child); + # FIXME: hangs if $child doesn't exits?! (D state) waitpid($child, 0); alarm $prev_alarm; die "interrupted by unexpected signal\n" if $sig_received; die $error if $error; - return $res; + return wantarray ? ($res, $got_timeout) : $res; } sub run_fork { @@ -1127,6 +1208,8 @@ sub upid_read_status { return 'OK'; } elsif ($line =~ m/^TASK ERROR: (.+)$/) { return $1; + } elsif ($line =~ m/^TASK (WARNINGS: \d+)$/) { + return $1; } else { return "unexpected status"; } @@ -1134,6 +1217,31 @@ sub upid_read_status { return "unable to read tail (got $br bytes)"; } +# Check if the status returned by upid_read_status is an error status. +# If the status could not be parsed it's also treated as an error. +sub upid_status_is_error { + my ($status) = @_; + + return !($status eq 'OK' || $status =~ m/^WARNINGS: \d+$/); +} + +# takes the parsed status and returns the type, either ok, warning, error or unknown +sub upid_normalize_status_type { + my ($status) = @_; + + if (!$status) { + return 'unknown'; + } elsif ($status eq 'OK') { + return 'ok'; + } elsif ($status =~ m/^WARNINGS: \d+$/) { + return 'warning'; + } elsif ($status eq 'unexpected status') { + return 'unknown'; + } else { + return 'error'; + } +} + # useful functions to store comments in config files sub encode_text { my ($text) = @_; @@ -1149,8 +1257,7 @@ sub decode_text { return Encode::decode("utf8", uri_unescape($data)); } -# depreciated - do not use! -# we now decode all parameters by default +# NOTE: deprecated - do not use! we now decode all parameters by default sub decode_utf8_parameters { my ($param) = @_; @@ -1204,54 +1311,76 @@ sub split_args { return $str ? [ Text::ParseWords::shellwords($str) ] : []; } -sub dump_logfile { - my ($filename, $start, $limit, $filter) = @_; +sub dump_logfile_by_filehandle { + my ($fh, $filter, $state) = @_; - my $lines = []; - my $count = 0; - - my $fh = IO::File->new($filename, "r"); - if (!$fh) { - $count++; - push @$lines, { n => $count, t => "unable to open file - $!"}; - return ($count, $lines); - } - - $start = 0 if !$start; - $limit = 50 if !$limit; + my $count = ($state->{count} //= 0); + my $lines = ($state->{lines} //= []); + my $start = ($state->{start} //= 0); + my $limit = ($state->{limit} //= 50); + my $final = ($state->{final} //= 1); + my $read_until_end = ($state->{read_until_end} //= $limit == 0); my $line; - if ($filter) { # duplicate code, so that we do not slow down normal path while (defined($line = <$fh>)) { - next if $line !~ m/$filter/; + if (ref($filter) eq 'CODE') { + next if !$filter->($line); + } else { + next if $line !~ m/$filter/; + } next if $count++ < $start; - next if $limit <= 0; + if (!$read_until_end) { + next if $limit <= 0; + $limit--; + } chomp $line; push @$lines, { n => $count, t => $line}; - $limit--; } } else { while (defined($line = <$fh>)) { next if $count++ < $start; - next if $limit <= 0; + if (!$read_until_end) { + next if $limit <= 0; + $limit--; + } chomp $line; push @$lines, { n => $count, t => $line}; - $limit--; } } - close($fh); - # HACK: ExtJS store.guaranteeRange() does not like empty array # so we add a line - if (!$count) { + if (!$count && $final) { $count++; push @$lines, { n => $count, t => "no content"}; } - return ($count, $lines); + $state->{count} = $count; + $state->{limit} = $limit; +} + +sub dump_logfile { + my ($filename, $start, $limit, $filter) = @_; + + my $fh = IO::File->new($filename, "r"); + if (!$fh) { + return (1, { n => 1, t => "unable to open file - $!"}); + } + + my %state = ( + 'count' => 0, + 'lines' => [], + 'start' => $start, + 'limit' => $limit, + ); + + dump_logfile_by_filehandle($fh, $filter, \%state); + + close($fh); + + return ($state{'count'}, $state{'lines'}); } sub dump_journal { @@ -1266,7 +1395,7 @@ sub dump_journal { my $parser = sub { my $line = shift; - return if $count++ < $start; + return if $count++ < $start; return if $limit <= 0; push @$lines, { n => int($count), t => $line}; $limit--; @@ -1359,8 +1488,10 @@ sub unpack_sockaddr_in46 { sub getaddrinfo_all { my ($hostname, @opts) = @_; - my %hints = ( flags => AI_V4MAPPED | AI_ALL, - @opts ); + my %hints = ( + flags => AI_V4MAPPED | AI_ALL, + @opts, + ); my ($err, @res) = Socket::getaddrinfo($hostname, '0', \%hints); die "failed to get address info for: $hostname: $err\n" if $err; return @res; @@ -1405,111 +1536,151 @@ sub parse_host_and_port { sub setresuid($$$) { my ($ruid, $euid, $suid) = @_; - return 0 == syscall(PVE::Syscall::setresuid, $ruid, $euid, $suid); + return 0 == syscall(PVE::Syscall::setresuid, int($ruid), int($euid), int($suid)); } sub unshare($) { my ($flags) = @_; - return 0 == syscall(PVE::Syscall::unshare, $flags); + return 0 == syscall(PVE::Syscall::unshare, int($flags)); } sub setns($$) { my ($fileno, $nstype) = @_; - return 0 == syscall(PVE::Syscall::setns, $fileno, $nstype); + return 0 == syscall(PVE::Syscall::setns, int($fileno), int($nstype)); } sub syncfs($) { my ($fileno) = @_; - return 0 == syscall(PVE::Syscall::syncfs, $fileno); + return 0 == syscall(PVE::Syscall::syncfs, int($fileno)); } sub fsync($) { my ($fileno) = @_; - return 0 == syscall(PVE::Syscall::fsync, $fileno); + return 0 == syscall(PVE::Syscall::fsync, int($fileno)); +} + +sub renameat2($$$$$) { + my ($olddirfd, $oldpath, $newdirfd, $newpath, $flags) = @_; + return 0 == syscall( + PVE::Syscall::renameat2, + int($olddirfd), + $oldpath, + int($newdirfd), + $newpath, + int($flags), + ); } sub sync_mountpoint { my ($path) = @_; - sysopen my $fd, $path, O_PATH or die "failed to open $path: $!\n"; - my $result = syncfs(fileno($fd)); + sysopen my $fd, $path, O_RDONLY|O_CLOEXEC or die "failed to open $path: $!\n"; + my $syncfs_err; + if (!syncfs(fileno($fd))) { + $syncfs_err = "$!"; + } close($fd); - return $result; + die "syncfs '$path' failed - $syncfs_err\n" if defined $syncfs_err; +} + +my sub check_mail_addr { + my ($addr) = @_; + die "'$addr' does not look like a valid email address or username\n" + if $addr !~ /^$EMAIL_RE$/ && $addr !~ /^$EMAIL_USER_RE$/; } # support sending multi-part mail messages with a text and or a HTML part # mailto may be a single email string or an array of receivers sub sendmail { my ($mailto, $subject, $text, $html, $mailfrom, $author) = @_; - my $mail_re = qr/[^-a-zA-Z0-9+._@]/; $mailto = [ $mailto ] if !ref($mailto); - foreach (@$mailto) { - die "illegal character in mailto address\n" - if ($_ =~ $mail_re); - } - - my $rcvrtxt = join (', ', @$mailto); + check_mail_addr($_) for $mailto->@*; + my $to_quoted = [ map { shellquote($_) } $mailto->@* ]; $mailfrom = $mailfrom || "root"; - die "illegal character in mailfrom address\n" - if $mailfrom =~ $mail_re; + check_mail_addr($mailfrom); + my $from_quoted = shellquote($mailfrom); + + $author = $author // 'Proxmox VE'; - $author = $author || 'Proxmox VE'; + open (my $mail, "|-", "sendmail", "-B", "8BITMIME", "-f", $from_quoted, "--", $to_quoted->@*) + or die "unable to open 'sendmail' - $!"; - open (MAIL, "|-", "sendmail", "-B", "8BITMIME", "-f", $mailfrom, "--", @$mailto) || - die "unable to open 'sendmail' - $!"; + my $is_multipart = $text && $html; + my $boundary = "----_=_NextPart_001_" . int(time()) . $$; # multipart spec, see rfc 1521 - # multipart spec see https://www.ietf.org/rfc/rfc1521.txt - my $boundary = "----_=_NextPart_001_".int(time).$$; + $subject = Encode::encode('MIME-Header', $subject) if $subject =~ /[^[:ascii:]]/; - print MAIL "Content-Type: multipart/alternative;\n"; - print MAIL "\tboundary=\"$boundary\"\n"; - print MAIL "MIME-Version: 1.0\n"; + print $mail "MIME-Version: 1.0\n" if $subject =~ /[^[:ascii:]]/ || $is_multipart; - print MAIL "FROM: $author <$mailfrom>\n"; - print MAIL "TO: $rcvrtxt\n"; - print MAIL "SUBJECT: $subject\n"; - print MAIL "\n"; - print MAIL "This is a multi-part message in MIME format.\n\n"; - print MAIL "--$boundary\n"; + print $mail "From: $author <$mailfrom>\n"; + print $mail "To: " . join(', ', @$mailto) ."\n"; + print $mail "Date: " . time2str('%a, %d %b %Y %H:%M:%S %z', time()) . "\n"; + print $mail "Subject: $subject\n"; + + if ($is_multipart) { + print $mail "Content-Type: multipart/alternative;\n"; + print $mail "\tboundary=\"$boundary\"\n"; + print $mail "\n"; + print $mail "This is a multi-part message in MIME format.\n\n"; + print $mail "--$boundary\n"; + } if (defined($text)) { - print MAIL "Content-Type: text/plain;\n"; - print MAIL "\tcharset=\"UTF8\"\n"; - print MAIL "Content-Transfer-Encoding: 8bit\n"; - print MAIL "\n"; + print $mail "Content-Type: text/plain;\n"; + print $mail "Auto-Submitted: auto-generated;\n"; + print $mail "\tcharset=\"UTF-8\"\n"; + print $mail "Content-Transfer-Encoding: 8bit\n"; + print $mail "\n"; # avoid 'remove extra line breaks' issue (MS Outlook) my $fill = ' '; $text =~ s/^/$fill/gm; - print MAIL $text; + print $mail $text; - print MAIL "\n--$boundary\n"; + print $mail "\n--$boundary\n" if $is_multipart; } if (defined($html)) { - print MAIL "Content-Type: text/html;\n"; - print MAIL "\tcharset=\"UTF8\"\n"; - print MAIL "Content-Transfer-Encoding: 8bit\n"; - print MAIL "\n"; + print $mail "Content-Type: text/html;\n"; + print $mail "Auto-Submitted: auto-generated;\n"; + print $mail "\tcharset=\"UTF-8\"\n"; + print $mail "Content-Transfer-Encoding: 8bit\n"; + print $mail "\n"; - print MAIL $html; + print $mail $html; - print MAIL "\n--$boundary--\n"; + print $mail "\n--$boundary--\n" if $is_multipart; } - close(MAIL); + close($mail); } +# creates a temporary file that does not shows up on the file system hierarchy. +# +# Uses O_TMPFILE if available, which makes it just an anon inode that never shows up in the FS. +# If O_TMPFILE is not available, which unlikely nowadays (added in 3.11 kernel and all FS relevant +# for us support it) back to open-create + immediate unlink while still holding the file handle. +# +# TODO: to avoid FS dependent features we could (transparently) switch to memfd_create as backend sub tempfile { my ($perm, %opts) = @_; # default permissions are stricter than with file_set_contents $perm = 0600 if !defined($perm); - my $dir = $opts{dir} // '/run'; + my $dir = $opts{dir}; + if (!$dir) { + if (-d "/run/user/$<") { + $dir = "/run/user/$<"; + } elsif ($< == 0) { + $dir = "/run"; + } else { + $dir = "/tmp"; + } + } my $mode = $opts{mode} // O_RDWR; $mode |= O_EXCL if !$opts{allow_links}; @@ -1524,6 +1695,7 @@ sub tempfile { return $fh; } +# create an (ideally) anon file with the $data as content and return its FD-path and FH sub tempfile_contents { my ($data, $perm, %opts) = @_; @@ -1557,7 +1729,11 @@ sub validate_ssh_public_keys { sub openat($$$;$) { my ($dirfd, $pathname, $flags, $mode) = @_; - my $fd = syscall(PVE::Syscall::openat, $dirfd, $pathname, $flags, $mode//0); + $dirfd = int($dirfd); + $flags = int($flags); + $mode = int($mode // 0); + + my $fd = syscall(PVE::Syscall::openat, $dirfd, $pathname, $flags, $mode); return undef if $fd < 0; # sysopen() doesn't deal with numeric file descriptors apparently # so we need to convert to a mode string for IO::Handle->new_from_fd @@ -1572,12 +1748,24 @@ sub openat($$$;$) { sub mkdirat($$$) { my ($dirfd, $name, $mode) = @_; - return syscall(PVE::Syscall::mkdirat, $dirfd, $name, $mode) == 0; + return syscall(PVE::Syscall::mkdirat, int($dirfd), $name, int($mode)) == 0; +} + +sub mknod($$$) { + my ($filename, $mode, $dev) = @_; + return syscall(PVE::Syscall::SYS_mknod, $filename, int($mode), int($dev)) == 0; } sub fchownat($$$$$) { my ($dirfd, $pathname, $owner, $group, $flags) = @_; - return syscall(PVE::Syscall::fchownat, $dirfd, $pathname, $owner, $group, $flags) == 0; + return syscall( + PVE::Syscall::fchownat, + int($dirfd), + $pathname, + int($owner), + int($group), + int($flags), + ) == 0; } my $salt_starter = time(); @@ -1707,9 +1895,9 @@ sub open_tree($$$) { my ($dfd, $pathname, $flags) = @_; return PVE::Syscall::file_handle_result(syscall( &PVE::Syscall::open_tree, - $dfd, + int($dfd), $pathname, - $flags, + int($flags), )); } @@ -1717,26 +1905,26 @@ sub move_mount($$$$$) { my ($from_dirfd, $from_pathname, $to_dirfd, $to_pathname, $flags) = @_; return 0 == syscall( &PVE::Syscall::move_mount, - $from_dirfd, + int($from_dirfd), $from_pathname, - $to_dirfd, + int($to_dirfd), $to_pathname, - $flags, + int($flags), ); } sub fsopen($$) { my ($fsname, $flags) = @_; - return PVE::Syscall::file_handle_result(syscall(&PVE::Syscall::fsopen, $fsname, $flags)); + return PVE::Syscall::file_handle_result(syscall(&PVE::Syscall::fsopen, $fsname, int($flags))); } sub fsmount($$$) { my ($fd, $flags, $mount_attrs) = @_; return PVE::Syscall::file_handle_result(syscall( &PVE::Syscall::fsmount, - $fd, - $flags, - $mount_attrs, + int($fd), + int($flags), + int($mount_attrs), )); } @@ -1744,15 +1932,22 @@ sub fspick($$$) { my ($dirfd, $pathname, $flags) = @_; return PVE::Syscall::file_handle_result(syscall( &PVE::Syscall::fspick, - $dirfd, + int($dirfd), $pathname, - $flags, + int($flags), )); } sub fsconfig($$$$$) { my ($fd, $command, $key, $value, $aux) = @_; - return 0 == syscall(&PVE::Syscall::fsconfig, $fd, $command, $key, $value, $aux); + return 0 == syscall( + &PVE::Syscall::fsconfig, + int($fd), + int($command), + $key, + $value, + int($aux), + ); } # "raw" mount, old api, not for generic use (as it does not invoke any helpers). @@ -1764,11 +1959,57 @@ sub mount($$$$$) { $source, $target, $filesystemtype, - $mountflags, + int($mountflags), $data, ); } +# size is optional and defaults to 256, note that xattr limits are FS specific and that xattrs can +# get arbitrary long. pass `0` for $size in array context to get the actual size of a value +sub getxattr($$;$) { + my ($path_or_handle, $name, $size) = @_; + $size //= 256; + my $buf = pack("x${size}"); + + my $xattr_size = -1; # the actual size of the xattr, can be zero + if (defined(my $fd = fileno($path_or_handle))) { + $xattr_size = syscall(&PVE::Syscall::fgetxattr, $fd, $name, $buf, int($size)); + } else { + $xattr_size = syscall(&PVE::Syscall::getxattr, $path_or_handle, $name, $buf, int($size)); + } + if ($xattr_size < 0) { + return undef; + } + $buf = substr($buf, 0, $xattr_size); + return wantarray ? ($buf, $xattr_size) : $buf; +} + +# NOTE: can take either a path or an open file handle, i.e., its multiplexing setxattr and fsetxattr +sub setxattr($$$;$) { + my ($path_or_handle, $name, $value, $flags) = @_; + my $size = length($value); # NOTE: seems to get correct length also for wide-characters in text.. + + if (defined(my $fd = fileno($path_or_handle))) { + return 0 == syscall( + &PVE::Syscall::fsetxattr, + $fd, + $name, + $value, + int($size), + int($flags // 0), + ); + } else { + return 0 == syscall( + &PVE::Syscall::setxattr, + $path_or_handle, + $name, + $value, + int($size), + int($flags // 0), + ); + } +} + sub safe_compare { my ($left, $right, $cmp) = @_; @@ -1778,4 +2019,166 @@ sub safe_compare { return $cmp->($left, $right); } + +# opts is a hash ref with the following known properties +# allow_overwrite - if 1, overwriting existing files is allowed, use with care. Default to false +# hash_required - if 1, at least one checksum has to be specified otherwise an error will be thrown +# http_proxy +# https_proxy +# verify_certificates - if 0 (false) we tell wget to ignore untrusted TLS certs. Default to true +# md5sum|sha(1|224|256|384|512)sum - the respective expected checksum string +sub download_file_from_url { + my ($dest, $url, $opts) = @_; + + my ($checksum_algorithm, $checksum_expected); + for ('sha512', 'sha384', 'sha256', 'sha224', 'sha1', 'md5') { + if (defined($opts->{"${_}sum"})) { + $checksum_algorithm = $_; + $checksum_expected = $opts->{"${_}sum"}; + last; + } + } + die "checksum required but not specified\n" if ($opts->{hash_required} && !$checksum_algorithm); + + print "downloading $url to $dest\n"; + + if (-f $dest) { + if ($checksum_algorithm) { + print "calculating checksum of existing file..."; + my $checksum_got = get_file_hash($checksum_algorithm, $dest); + + if (lc($checksum_got) eq lc($checksum_expected)) { + print "OK, got correct file already, no need to download\n"; + return; + } elsif ($opts->{allow_overwrite}) { + print "checksum mismatch: got '$checksum_got' != expect '$checksum_expected', re-download\n"; + } else { + print "\n"; # the front end expects the error to reside at the last line without any noise + die "checksum mismatch: got '$checksum_got' != expect '$checksum_expected', aborting\n"; + } + } elsif (!$opts->{allow_overwrite}) { + die "refusing to override existing file '$dest'\n"; + } + } + + my $tmp_download = "$dest.tmp_dwnl.$$"; + my $tmp_decomp = "$dest.tmp_dcom.$$"; + eval { + local $SIG{INT} = sub { + unlink $tmp_download or warn "could not cleanup temporary file: $!" + if -e $tmp_download; + unlink $tmp_decomp or warn "could not cleanup temporary file: $!" + if $opts->{decompression_command} && -e $tmp_decomp; + die "got interrupted by signal\n"; + }; + + { # limit the scope of the ENV change + local %ENV; + if ($opts->{http_proxy}) { + $ENV{http_proxy} = $opts->{http_proxy}; + } + if ($opts->{https_proxy}) { + $ENV{https_proxy} = $opts->{https_proxy}; + } + + my $cmd = ['wget', '--progress=dot:giga', '-O', $tmp_download, $url]; + + if (!($opts->{verify_certificates} // 1)) { # default to true + push @$cmd, '--no-check-certificate'; + } + + run_command($cmd, errmsg => "download failed"); + } + + if ($checksum_algorithm) { + print "calculating checksum..."; + + my $checksum_got = get_file_hash($checksum_algorithm, $tmp_download); + + if (lc($checksum_got) eq lc($checksum_expected)) { + print "OK, checksum verified\n"; + } else { + print "\n"; # the front end expects the error to reside at the last line without any noise + die "checksum mismatch: got '$checksum_got' != expect '$checksum_expected'\n"; + } + } + + if (my $cmd = $opts->{decompression_command}) { + push @$cmd, $tmp_download; + my $fh; + if (!open($fh, ">", "$tmp_decomp")) { + die "cant open temporary file $tmp_decomp for decompresson: $!\n"; + } + print "decompressing $tmp_download to $tmp_decomp\n"; + run_command($cmd, output => '>&'.fileno($fh)); + unlink $tmp_download; + rename($tmp_decomp, $dest) or die "unable to rename temporary file: $!\n"; + } else { + rename($tmp_download, $dest) or die "unable to rename temporary file: $!\n"; + } + }; + if (my $err = $@) { + unlink $tmp_download or warn "could not cleanup temporary file: $!" + if -e $tmp_download; + unlink $tmp_decomp or warn "could not cleanup temporary file: $!" + if $opts->{decompression_command} && -e $tmp_decomp; + die $err; + } + + print "download of '$url' to '$dest' finished\n"; +} + +sub get_file_hash { + my ($algorithm, $filename) = @_; + + my $algorithm_map = { + 'md5' => sub { Digest::MD5->new }, + 'sha1' => sub { Digest::SHA->new(1) }, + 'sha224' => sub { Digest::SHA->new(224) }, + 'sha256' => sub { Digest::SHA->new(256) }, + 'sha384' => sub { Digest::SHA->new(384) }, + 'sha512' => sub { Digest::SHA->new(512) }, + }; + + my $digester = $algorithm_map->{$algorithm}->() or die "unknown algorithm '$algorithm'\n"; + + open(my $fh, '<', $filename) or die "unable to open '$filename': $!\n"; + binmode($fh); + + my $digest = $digester->addfile($fh)->hexdigest; + + return lc($digest); +} + +# compare two perl variables recursively, so this works for scalars, nested +# hashes and nested arrays +sub is_deeply { + my ($a, $b) = @_; + + return 0 if defined($a) != defined($b); + return 1 if !defined($a); # both are undef + + my ($ref_a, $ref_b) = (ref($a), ref($b)); + + # scalar case + return 0 if !$ref_a && !$ref_b && "$a" ne "$b"; + + # different types, ok because ref never returns undef, only empty string + return 0 if $ref_a ne $ref_b; + + if ($ref_a eq 'HASH') { + return 0 if scalar(keys $a->%*) != scalar(keys $b->%*); + for my $opt (keys $a->%*) { + return 0 if !is_deeply($a->{$opt}, $b->{$opt}); + } + } elsif ($ref_a eq 'ARRAY') { + return 0 if scalar($a->@*) != scalar($b->@*); + for (my $i = 0; $i < $a->@*; $i++) { + return 0 if !is_deeply($a->[$i], $b->[$i]); + } + } + + return 1; +} + 1;