X-Git-Url: https://git.proxmox.com/?p=pve-common.git;a=blobdiff_plain;f=src%2FPVE%2FTools.pm;h=accf6539da94d2b5d5b6f4539310fe5c4d526c7e;hp=3f3958e0e354f4f5f4cbe6fea92028fdd58f6e19;hb=0a3de87e0f68078652ca3293c1bd1cc377c27f9d;hpb=cd9bd2526a6c7a74d3f8ce3de32bc149d96324f3 diff --git a/src/PVE/Tools.pm b/src/PVE/Tools.pm index 3f3958e..accf653 100644 --- a/src/PVE/Tools.pm +++ b/src/PVE/Tools.pm @@ -2,23 +2,30 @@ package PVE::Tools; use strict; use warnings; -use POSIX qw(EINTR); +use POSIX qw(EINTR EEXIST EOPNOTSUPP); use IO::Socket::IP; -use Socket qw(AF_INET AF_INET6 AI_ALL AI_V4MAPPED); +use Socket qw(AF_INET AF_INET6 AI_ALL AI_V4MAPPED AI_CANONNAME SOCK_DGRAM + IPPROTO_TCP); use IO::Select; 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::Handle; 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 String::ShellQuote; use Time::HiRes qw(usleep gettimeofday tv_interval alarm); +use Scalar::Util 'weaken'; +use PVE::Syscall; # avoid warning when parsing long hex values with hex() no warnings 'portable'; # Support for 64-bit ints required @@ -26,10 +33,10 @@ no warnings 'portable'; # Support for 64-bit ints required our @EXPORT_OK = qw( $IPV6RE $IPV4RE -lock_file +lock_file lock_file_full -run_command -file_set_contents +run_command +file_set_contents file_get_contents file_read_firstline dir_glob_regex @@ -39,6 +46,9 @@ template_replace safe_print trim extract_param +file_copy +O_PATH +O_TMPFILE ); my $pvelogdir = "/var/log/pve"; @@ -65,12 +75,15 @@ our $IPV6RE = "(?:" . our $IPRE = "(?:$IPV4RE|$IPV6RE)"; -use constant (CLONE_NEWNS => 0x00020000, +use constant {CLONE_NEWNS => 0x00020000, CLONE_NEWUTS => 0x04000000, CLONE_NEWIPC => 0x08000000, CLONE_NEWUSER => 0x10000000, CLONE_NEWPID => 0x20000000, - CLONE_NEWNET => 0x40000000); + CLONE_NEWNET => 0x40000000}; + +use constant {O_PATH => 0x00200000, + O_TMPFILE => 0x00410000}; # This includes O_DIRECTORY sub run_with_timeout { my ($timeout, $code, @param) = @_; @@ -110,7 +123,12 @@ sub run_with_timeout { } # flock: we use one file handle per process, so lock file -# can be called multiple times and succeeds for the same process. +# can be nested multiple times and succeeds for the same process. +# +# Since this is the only way we lock now and we don't have the old +# 'lock(); code(); unlock();' pattern anymore we do not actually need to +# count how deep we're nesting. Therefore this hash now stores a weak reference +# to a boolean telling us whether we already have a lock. my $lock_handles = {}; @@ -121,53 +139,67 @@ sub lock_file_full { my $mode = $shared ? LOCK_SH : LOCK_EX; - my $lock_func = sub { - if (!$lock_handles->{$$}->{$filename}) { - $lock_handles->{$$}->{$filename} = new IO::File (">>$filename") || - die "can't open file - $!\n"; - } + my $lockhash = ($lock_handles->{$$} //= {}); + + # Returns a locked file handle. + my $get_locked_file = sub { + my $fh = IO::File->new(">>$filename") + or die "can't open file - $!\n"; - if (!flock ($lock_handles->{$$}->{$filename}, $mode|LOCK_NB)) { - print STDERR "trying to aquire lock..."; + if (!flock($fh, $mode|LOCK_NB)) { + print STDERR "trying to acquire lock...\n"; my $success; while(1) { - $success = flock($lock_handles->{$$}->{$filename}, $mode); + $success = flock($fh, $mode); # try again on EINTR (see bug #273) if ($success || ($! != EINTR)) { last; } } - if (!$success) { - print STDERR " failed\n"; - die "can't aquire lock - $!\n"; - } - print STDERR " OK\n"; - } + if (!$success) { + print STDERR " failed\n"; + die "can't acquire lock '$filename' - $!\n"; + } + print STDERR " OK\n"; + } + + return $fh; }; my $res; - - eval { run_with_timeout($timeout, $lock_func); }; - my $err = $@; - if ($err) { - $err = "can't lock file '$filename' - $err"; - } else { - eval { $res = &$code(@param) }; - $err = $@; - } - - if (my $fh = $lock_handles->{$$}->{$filename}) { - $lock_handles->{$$}->{$filename} = undef; - close ($fh); - } - - if ($err) { - $@ = $err; - return undef; + my $checkptr = $lockhash->{$filename}; + my $check = 0; # This must not go out of scope before running the code. + my $local_fh; # This must stay local + if (!$checkptr || !$$checkptr) { + # We cannot create a weak reference in a single atomic step, so we first + # create a false-value, then create a reference to it, then weaken it, + # and after successfully locking the file we change the boolean value. + # + # The reason for this is that if an outer SIGALRM throws an exception + # between creating the reference and weakening it, a subsequent call to + # lock_file_full() will see a leftover full reference to a valid + # variable. This variable must be 0 in order for said call to attempt to + # lock the file anew. + # + # An externally triggered exception elsewhere in the code will cause the + # weak reference to become 'undef', and since the file handle is only + # stored in the local scope in $local_fh, the file will be closed by + # perl's cleanup routines as well. + # + # This still assumes that an IO::File handle can properly deal with such + # exceptions thrown during its own destruction, but that's up to perls + # guts now. + $lockhash->{$filename} = \$check; + weaken $lockhash->{$filename}; + $local_fh = eval { run_with_timeout($timeout, $get_locked_file) }; + if ($@) { + $@ = "can't lock file '$filename' - $@"; + return undef; + } + $check = 1; } - - $@ = undef; - + $res = eval { &$code(@param); }; + return undef if $@; return $res; } @@ -186,7 +218,13 @@ sub file_set_contents { my $tmpname = "$filename.tmp.$$"; eval { - my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm); + my ($fh, $tries) = (undef, 0); + while (!$fh && $tries++ < 3) { + $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT|O_EXCL, $perm); + if (!$fh && $! == EEXIST) { + unlink($tmpname) or die "unable to delete old temp file: $!\n"; + } + } die "unable to open file '$tmpname' - $!\n" if !$fh; die "unable to write '$tmpname' - $!\n" unless print $fh $data; die "closing file '$tmpname' failed - $!\n" unless close $fh; @@ -201,7 +239,7 @@ sub file_set_contents { if (!rename($tmpname, $filename)) { my $msg = "close (rename) atomic file '$filename' failed: $!\n"; unlink $tmpname; - die $msg; + die $msg; } } @@ -211,13 +249,19 @@ sub file_get_contents { my $fh = IO::File->new($filename, "r") || die "can't open '$filename' - $!\n"; - my $content = safe_read_from($fh, $max); + my $content = safe_read_from($fh, $max, 0, $filename); close $fh; return $content; } +sub file_copy { + my ($filename, $dst, $max, $perm) = @_; + + file_set_contents ($dst, file_get_contents($filename, $max), $perm); +} + sub file_read_firstline { my ($filename) = @_; @@ -230,22 +274,24 @@ sub file_read_firstline { } sub safe_read_from { - my ($fh, $max, $oneline) = @_; + my ($fh, $max, $oneline, $filename) = @_; $max = 32768 if !$max; + my $subject = defined($filename) ? "file '$filename'" : 'input'; + my $br = 0; my $input = ''; my $count; while ($count = sysread($fh, $input, 8192, $br)) { $br += $count; - die "input too long - aborting\n" if $br > $max; + die "$subject too long - aborting\n" if $br > $max; if ($oneline && $input =~ m/^(.*)\n/) { $input = $1; last; } - } - die "unable to read input - $!\n" if !defined($count); + } + die "unable to read $subject - $!\n" if !defined($count); return $input; } @@ -291,7 +337,7 @@ sub run_command { $cmdstr .= $pipe . join(' ', map { ref($_) ? $$_ : shellquote($_) } @$command); $pipe = ' | '; } - $cmd = [ '/bin/bash', '-c', "set -o pipefail && $cmdstr" ]; + $cmd = [ '/bin/bash', '-c', "$cmdstr" ]; } else { $cmdstr = cmd2string($cmd); } @@ -310,6 +356,7 @@ sub run_command { my $timeout; my $oldtimeout; my $pid; + my $exitcode = -1; my $outfunc; my $errfunc; @@ -317,6 +364,9 @@ sub run_command { my $input; my $output; my $afterfork; + my $noerr; + my $keeplocale; + my $quiet; eval { @@ -339,6 +389,12 @@ sub run_command { $logfunc = $param{$p}; } elsif ($p eq 'afterfork') { $afterfork = $param{$p}; + } elsif ($p eq 'noerr') { + $noerr = $param{$p}; + } elsif ($p eq 'keeplocale') { + $keeplocale = $param{$p}; + } elsif ($p eq 'quiet') { + $quiet = $param{$p}; } else { die "got unknown parameter '$p' for run_command\n"; } @@ -354,7 +410,7 @@ sub run_command { print STDERR "$laststderr\n" if $laststderr; } } - $laststderr = shift; + $laststderr = shift; }; } @@ -362,13 +418,10 @@ sub run_command { my $writer = $input && $input =~ m/^<&/ ? $input : IO::File->new(); my $error = IO::File->new(); - # try to avoid locale related issues/warnings - my $lang = $param{lang} || 'C'; - my $orig_pid = $$; eval { - local $ENV{LC_ALL} = $lang; + local $ENV{LC_ALL} = 'C' if !$keeplocale; # suppress LVM warnings like: "File descriptor 3 left open"; local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1"; @@ -390,8 +443,8 @@ sub run_command { # catch exec errors if ($orig_pid != $$) { warn "ERROR: $err"; - POSIX::_exit (1); - kill ('KILL', $$); + POSIX::_exit (1); + kill ('KILL', $$); } die $err if $err; @@ -444,7 +497,7 @@ sub run_command { waitpid ($pid, 0); die $err; } - } else { + } elsif (!$quiet) { print $buf; *STDOUT->flush(); } @@ -464,7 +517,7 @@ sub run_command { waitpid ($pid, 0); die $err; } - } else { + } elsif (!$quiet) { print STDERR $buf; *STDERR->flush(); } @@ -479,19 +532,19 @@ sub run_command { &$logfunc($errlog) if $logfunc && $errlog; waitpid ($pid, 0); - + if ($? == -1) { die "failed to execute\n"; } elsif (my $sig = ($? & 127)) { die "got signal $sig\n"; - } elsif (my $ec = ($? >> 8)) { - if (!($ec == 24 && ($cmdstr =~ m|^(\S+/)?rsync\s|))) { + } elsif ($exitcode = ($? >> 8)) { + if (!($exitcode == 24 && ($cmdstr =~ m|^(\S+/)?rsync\s|))) { if ($errmsg && $laststderr) { my $lerr = $laststderr; $laststderr = undef; die "$lerr\n"; } - die "exit code $ec\n"; + die "exit code $exitcode\n"; } } @@ -520,19 +573,77 @@ sub run_command { if ($errmsg) { $err =~ s/^usermod:\s*// if $cmdstr =~ m|^(\S+/)?usermod\s|; die "$errmsg: $err"; - } else { + } elsif(!$noerr) { die "command '$cmdstr' failed: $err"; } } + return $exitcode; +} + +# Run a command with a tcp socket as standard input. +sub pipe_socket_to_command { + my ($cmd, $ip, $port) = @_; + + my $params = { + Listen => 1, + ReuseAddr => 1, + Proto => &Socket::IPPROTO_TCP, + GetAddrInfoFlags => 0, + LocalAddr => $ip, + LocalPort => $port, + }; + my $socket = IO::Socket::IP->new(%$params) or die "failed to open socket: $!\n"; + + print "$ip\n$port\n"; # tell remote where to connect + *STDOUT->flush(); + + alarm 0; + local $SIG{ALRM} = sub { die "timed out waiting for client\n" }; + alarm 30; + my $client = $socket->accept; # Wait for a client + alarm 0; + close($socket); + + # We want that the command talks over the TCP socket and takes + # ownership of it, so that when it closes it the connection is + # terminated, so we need to be able to close the socket. So we + # can't really use PVE::Tools::run_command(). + my $pid = fork() // die "fork failed: $!\n"; + if (!$pid) { + POSIX::dup2(fileno($client), 0); + POSIX::dup2(fileno($client), 1); + close($client); + exec {$cmd->[0]} @$cmd or do { + warn "exec failed: $!\n"; + POSIX::_exit(1); + }; + } + + close($client); + if (waitpid($pid, 0) != $pid) { + kill(15 => $pid); # if we got interrupted terminate the child + my $count = 0; + while (waitpid($pid, POSIX::WNOHANG) != $pid) { + usleep(100000); + $count++; + kill(9 => $pid), last if $count > 300; # 30 second timeout + } + } + if (my $sig = ($? & 127)) { + die "got signal $sig\n"; + } elsif (my $exitcode = ($? >> 8)) { + die "exit code $exitcode\n"; + } + return undef; } sub split_list { - my $listtxt = shift || ''; + my $listtxt = shift // ''; return split (/\0/, $listtxt) if $listtxt =~ m/\0/; - + $listtxt =~ s/[,;]/ /g; $listtxt =~ s/^\s+//; @@ -548,7 +659,7 @@ sub trim { $txt =~ s/^\s+//; $txt =~ s/\s+$//; - + return $txt; } @@ -557,9 +668,9 @@ sub template_replace { my ($tmpl, $data) = @_; return $tmpl if !$tmpl; - + my $res = ''; - while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) { + while ($tmpl =~ m/([^{]+)?(\{([^}]+)\})?/g) { $res .= $1 if $1; $res .= ($data->{$3} || '-') if $2; } @@ -624,7 +735,7 @@ sub debmirrors { my $keymaphash = { 'dk' => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'], 'de' => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ], - 'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ], + 'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ], 'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', undef], 'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', undef ], 'es' => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'], @@ -645,11 +756,11 @@ my $keymaphash = { 'mk' => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'], 'nl' => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef], #'nl-be' => ['Belgium-Dutch', 'nl-be', ?, ?, ?], - 'no' => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'], + 'no' => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'], 'pl' => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef], 'pt' => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'], 'pt-br' => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'], - #'ru' => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know? + #'ru' => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # don't know? 'si' => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef], 'se' => ['Swedish', 'sv', 'qwerty/se-latin1.kmap.gz', 'se', 'nodeadkeys'], #'th' => [], @@ -657,7 +768,7 @@ my $keymaphash = { }; my $kvmkeymaparray = []; -foreach my $lc (keys %$keymaphash) { +foreach my $lc (sort keys %$keymaphash) { push @$kvmkeymaparray, $keymaphash->{$lc}->[1]; } @@ -680,34 +791,35 @@ sub extract_param { # Note: we use this to wait until vncterm/spiceterm is ready sub wait_for_vnc_port { - my ($port, $timeout) = @_; + my ($port, $family, $timeout) = @_; $timeout = 5 if !$timeout; my $sleeptime = 0; my $starttime = [gettimeofday]; my $elapsed; + my $cmd = ['/bin/ss', '-Htln', "sport = :$port"]; + push @$cmd, $family == AF_INET6 ? '-6' : '-4' if defined($family); + + my $found; while (($elapsed = tv_interval($starttime)) < $timeout) { - if (my $fh = IO::File->new ("/proc/net/tcp", "r")) { - while (defined (my $line = <$fh>)) { - if ($line =~ m/^\s*\d+:\s+([0-9A-Fa-f]{8}):([0-9A-Fa-f]{4})\s/) { - if ($port == hex($2)) { - close($fh); - return 1; - } - } + # -Htln = don't print header, tcp, listening sockets only, numeric ports + run_command($cmd, outfunc => sub { + my $line = shift; + if ($line =~ m/^LISTEN\s+\d+\s+\d+\s+\S+:(\d+)\s/) { + $found = 1 if ($port == $1); } - close($fh); - } + }); + return 1 if $found; $sleeptime += 100000 if $sleeptime < 1000000; usleep($sleeptime); } - return undef; + die "Timeout while waiting for port '$port' to get ready!\n"; } sub next_unused_port { - my ($range_start, $range_end, $family) = @_; + my ($range_start, $range_end, $family, $address) = @_; # We use a file to register allocated ports. # Those registrations expires after $expiretime. @@ -729,22 +841,24 @@ sub next_unused_port { my ($port, $timestamp) = ($1, $2); if (($timestamp + $expiretime) > $ctime) { $ports->{$port} = $timestamp; # not expired - } + } } } } - + my $newport; + my %sockargs = (Listen => 5, + ReuseAddr => 1, + Family => $family, + Proto => IPPROTO_TCP, + GetAddrInfoFlags => 0); + $sockargs{LocalAddr} = $address if defined($address); for (my $p = $range_start; $p < $range_end; $p++) { next if $ports->{$p}; # reserved - my $sock = IO::Socket::IP->new(Listen => 5, - LocalPort => $p, - ReuseAddr => 1, - Family => $family, - Proto => 0, - GetAddrInfoFlags => 0); + $sockargs{LocalPort} = $p; + my $sock = IO::Socket::IP->new(%sockargs); if ($sock) { close($sock); @@ -753,76 +867,168 @@ sub next_unused_port { last; } } - + my $data = ""; foreach my $p (keys %$ports) { $data .= "$p $ports->{$p}\n"; } - + file_set_contents($filename, $data); return $newport; }; - my $p = lock_file($filename, 10, $code); + my $p = lock_file('/var/lock/pve-ports.lck', 10, $code); die $@ if $@; - + die "unable to find free port (${range_start}-${range_end})\n" if !$p; return $p; } sub next_migrate_port { - my ($family) = @_; - return next_unused_port(60000, 60050, $family); + my ($family, $address) = @_; + return next_unused_port(60000, 60050, $family, $address); } sub next_vnc_port { - my ($family) = @_; - return next_unused_port(5900, 6000, $family); + my ($family, $address) = @_; + return next_unused_port(5900, 6000, $family, $address); } sub next_spice_port { - my ($family) = @_; - return next_unused_port(61000, 61099, $family); + my ($family, $address) = @_; + return next_unused_port(61000, 61099, $family, $address); +} + +sub must_stringify { + my ($value) = @_; + eval { $value = "$value" }; + return "error turning value into a string: $@" if $@; + return $value; +} + +# sigkill after $timeout a $sub running in a fork if it can't write a pipe +# the $sub has to return a single scalar +sub run_fork_with_timeout { + my ($timeout, $sub) = @_; + + my $res; + my $error; + my $pipe_out = IO::Pipe->new(); + + # disable pending alarms, save their remaining time + my $prev_alarm = alarm 0; + + # avoid leaving a zombie if the parent gets interrupted + my $sig_received; + + my $child = fork(); + if (!defined($child)) { + die "fork failed: $!\n"; + return $res; + } + + if (!$child) { + $pipe_out->writer(); + + eval { + $res = $sub->(); + print {$pipe_out} encode_json({ result => $res }); + $pipe_out->flush(); + }; + if (my $err = $@) { + print {$pipe_out} encode_json({ error => must_stringify($err) }); + $pipe_out->flush(); + POSIX::_exit(1); + } + POSIX::_exit(0); + } + + local $SIG{INT} = sub { $sig_received++; }; + local $SIG{TERM} = sub { + $error //= "interrupted by unexpected signal\n"; + kill('TERM', $child); + }; + + $pipe_out->reader(); + + my $readvalues = sub { + local $/ = undef; + my $child_res = decode_json(readline_nointr($pipe_out)); + $res = $child_res->{result}; + $error = $child_res->{error}; + }; + eval { + if (defined($timeout)) { + run_with_timeout($timeout, $readvalues); + } else { + $readvalues->(); + } + }; + warn $@ if $@; + $pipe_out->close(); + kill('KILL', $child); + waitpid($child, 0); + + alarm $prev_alarm; + die "interrupted by unexpected signal\n" if $sig_received; + + die $error if $error; + return $res; } -# NOTE: NFS syscall can't be interrupted, so alarm does +sub run_fork { + my ($code) = @_; + return run_fork_with_timeout(undef, $code); +} + +# NOTE: NFS syscall can't be interrupted, so alarm does # not work to provide timeouts. # from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation" -# So the spawn external 'df' process instead of using -# Filesys::Df (which uses statfs syscall) +# So fork() before using Filesys::Df sub df { my ($path, $timeout) = @_; - my $cmd = [ 'df', '-P', '-B', '1', $path]; + my $df = sub { return Filesys::Df::df($path, 1) }; + + my $res = eval { run_fork_with_timeout($timeout, $df) } // {}; + warn $@ if $@; + + # untaint the values + my ($blocks, $used, $bavail) = map { defined($_) ? (/^(\d+)$/) : 0 } + $res->@{qw(blocks used bavail)}; - my $res = { - total => 0, - used => 0, - avail => 0, + return { + total => $blocks, + used => $used, + avail => $bavail, }; +} + +sub du { + my ($path, $timeout) = @_; + + my $size; + + $timeout //= 10; my $parser = sub { my $line = shift; - if (my ($fsid, $total, $used, $avail) = $line =~ - m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) { - $res = { - total => $total, - used => $used, - avail => $avail, - }; + + if ($line =~ m/^(\d+)\s+total$/) { + $size = $1; } }; - eval { run_command($cmd, timeout => $timeout, outfunc => $parser); }; - warn $@ if $@; - return $res; + run_command(['du', '-scb', $path], outfunc => $parser, timeout => $timeout); + + return $size; } # UPID helper # We use this to uniquely identify a process. -# An 'Unique Process ID' has the following format: +# An 'Unique Process ID' has the following format: # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user" sub upid_encode { @@ -830,8 +1036,8 @@ sub upid_encode { # Note: pstart can be > 32bit if uptime > 497 days, so this can result in # more that 8 characters for pstart - return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid}, - $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id}, + return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid}, + $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id}, $d->{user}); } @@ -866,7 +1072,7 @@ sub upid_decode { sub upid_open { my ($upid) = @_; - my ($task, $filename) = upid_decode($upid); + my ($task, $filename) = upid_decode($upid); my $dirname = dirname($filename); make_path($dirname); @@ -875,7 +1081,7 @@ sub upid_open { die "getpwnam failed"; my $perm = 0640; - + my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) || die "unable to create output file '$filename' - $!\n"; chown $wwwid, -1, $outfh; @@ -909,7 +1115,7 @@ sub upid_read_status { return "unable to read tail (got $br bytes)"; } -# useful functions to store comments in config files +# useful functions to store comments in config files sub encode_text { my ($text) = @_; @@ -924,6 +1130,8 @@ sub decode_text { return Encode::decode("utf8", uri_unescape($data)); } +# depreciated - do not use! +# we now decode all parameters by default sub decode_utf8_parameters { my ($param) = @_; @@ -935,28 +1143,20 @@ sub decode_utf8_parameters { } sub random_ether_addr { + my ($prefix) = @_; my ($seconds, $microseconds) = gettimeofday; - my $rand = Digest::SHA::sha1_hex($$, rand(), $seconds, $microseconds); + my $rand = Digest::SHA::sha1($$, rand(), $seconds, $microseconds); - my $mac = ''; - for (my $i = 0; $i < 6; $i++) { - my $ss = hex(substr($rand, $i*2, 2)); - if (!$i) { - $ss &= 0xfe; # clear multicast - $ss |= 2; # set local id - } - $ss = sprintf("%02X", $ss); + # clear multicast, set local id + vec($rand, 0, 8) = (vec($rand, 0, 8) & 0xfe) | 2; - if (!$i) { - $mac .= "$ss"; - } else { - $mac .= ":$ss"; - } + my $addr = sprintf("%02X:%02X:%02X:%02X:%02X:%02X", unpack("C6", $rand)); + if (defined($prefix)) { + $addr = uc($prefix) . substr($addr, length($prefix)); } - - return $mac; + return $addr; } sub shellquote { @@ -992,7 +1192,7 @@ sub dump_logfile { my $count = 0; my $fh = IO::File->new($filename, "r"); - if (!$fh) { + if (!$fh) { $count++; push @$lines, { n => $count, t => "unable to open file - $!"}; return ($count, $lines); @@ -1036,11 +1236,11 @@ sub dump_logfile { } sub dump_journal { - my ($start, $limit, $filter) = @_; + my ($start, $limit, $since, $until, $service) = @_; my $lines = []; my $count = 0; - + $start = 0 if !$start; $limit = 50 if !$limit; @@ -1054,6 +1254,10 @@ sub dump_journal { }; my $cmd = ['journalctl', '-o', 'short', '--no-pager']; + + push @$cmd, '--unit', $service if $service; + push @$cmd, '--since', $since if $since; + push @$cmd, '--until', $until if $until; run_command($cmd, outfunc => $parser); # HACK: ExtJS store.guaranteeRange() does not like empty array @@ -1071,8 +1275,8 @@ sub dir_glob_regex { my $dh = IO::Dir->new ($dir); return wantarray ? () : undef if !$dh; - - while (defined(my $tmp = $dh->read)) { + + while (defined(my $tmp = $dh->read)) { if (my @res = $tmp =~ m/^($regex)$/) { $dh->close; return wantarray ? @res : $tmp; @@ -1093,7 +1297,7 @@ sub dir_glob_foreach { &$func (@res); } } - } + } } sub assert_if_modified { @@ -1149,6 +1353,24 @@ sub get_host_address_family { return $res[0]->{family}; } +# get the fully qualified domain name of a host +# same logic as hostname(1): The FQDN is the name getaddrinfo(3) returns, +# given a nodename as a parameter +sub get_fqdn { + my ($nodename) = @_; + + my $hints = { + flags => AI_CANONNAME, + socktype => SOCK_DGRAM + }; + + my ($err, @addrs) = Socket::getaddrinfo($nodename, undef, $hints); + + die "getaddrinfo: $err" if $err; + + return $addrs[0]->{canonname}; +} + # Parses any sane kind of host, or host+port pair: # The port is always optional and thus may be undef. sub parse_host_and_port { @@ -1162,9 +1384,247 @@ sub parse_host_and_port { return; # nothing } -sub unshare { +sub unshare($) { my ($flags) = @_; - syscall 272, $flags; + return 0 == syscall(PVE::Syscall::unshare, $flags); +} + +sub setns($$) { + my ($fileno, $nstype) = @_; + return 0 == syscall(PVE::Syscall::setns, $fileno, $nstype); +} + +sub syncfs($) { + my ($fileno) = @_; + return 0 == syscall(PVE::Syscall::syncfs, $fileno); +} + +sub sync_mountpoint { + my ($path) = @_; + sysopen my $fd, $path, O_PATH or die "failed to open $path: $!\n"; + my $result = syncfs(fileno($fd)); + close($fd); + return $result; +} + +# 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); + + $mailfrom = $mailfrom || "root"; + die "illegal character in mailfrom address\n" + if $mailfrom =~ $mail_re; + + $author = $author || 'Proxmox VE'; + + open (MAIL, "|-", "sendmail", "-B", "8BITMIME", "-f", $mailfrom, @$mailto) || + die "unable to open 'sendmail' - $!"; + + # multipart spec see https://www.ietf.org/rfc/rfc1521.txt + my $boundary = "----_=_NextPart_001_".int(time).$$; + + print MAIL "Content-Type: multipart/alternative;\n"; + print MAIL "\tboundary=\"$boundary\"\n"; + print MAIL "MIME-Version: 1.0\n"; + + 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"; + + 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"; + + # avoid 'remove extra line breaks' issue (MS Outlook) + my $fill = ' '; + $text =~ s/^/$fill/gm; + + print MAIL $text; + + print MAIL "\n--$boundary\n"; + } + + 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 $html; + + print MAIL "\n--$boundary--\n"; + } + + close(MAIL); +} + +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 $mode = $opts{mode} // O_RDWR; + $mode |= O_EXCL if !$opts{allow_links}; + + my $fh = IO::File->new($dir, $mode | O_TMPFILE, $perm); + if (!$fh && $! == EOPNOTSUPP) { + $dir = '/tmp' if !defined($opts{dir}); + $dir .= "/.tmpfile.$$"; + $fh = IO::File->new($dir, $mode | O_CREAT | O_EXCL, $perm); + unlink($dir) if $fh; + } + die "failed to create tempfile: $!\n" if !$fh; + return $fh; +} + +sub tempfile_contents { + my ($data, $perm, %opts) = @_; + + my $fh = tempfile($perm, %opts); + eval { + die "unable to write to tempfile: $!\n" if !print {$fh} $data; + die "unable to flush to tempfile: $!\n" if !defined($fh->flush()); + }; + if (my $err = $@) { + close $fh; + die $err; + } + + return ("/proc/$$/fd/".$fh->fileno, $fh); +} + +sub validate_ssh_public_keys { + my ($raw) = @_; + my @lines = split(/\n/, $raw); + + foreach my $line (@lines) { + next if $line =~ m/^\s*$/; + eval { + my ($filename, $handle) = tempfile_contents($line); + run_command(["ssh-keygen", "-l", "-f", $filename], + outfunc => sub {}, errfunc => sub {}); + }; + die "SSH public key validation error\n" if $@; + } +} + +sub openat($$$;$) { + my ($dirfd, $pathname, $flags, $mode) = @_; + my $fd = syscall(PVE::Syscall::openat, $dirfd, $pathname, $flags, $mode//0); + 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 + my $flagstr = ($flags & O_RDWR) ? 'rw' : ($flags & O_WRONLY) ? 'w' : 'r'; + my $handle = IO::Handle->new_from_fd($fd, $flagstr); + return $handle if $handle; + my $err = $!; # save error before closing the raw fd + syscall(PVE::Syscall::close, $fd); # close + $! = $err; + return undef; +} + +sub mkdirat($$$) { + my ($dirfd, $name, $mode) = @_; + return syscall(PVE::Syscall::mkdirat, $dirfd, $name, $mode) == 0; +} + +my $salt_starter = time(); + +sub encrypt_pw { + my ($pw) = @_; + + $salt_starter++; + my $salt = substr(Digest::SHA::sha1_base64(time() + $salt_starter + $$), 0, 8); + + # crypt does not want '+' in salt (see 'man crypt') + $salt =~ s/\+/X/g; + + return crypt(encode("utf8", $pw), "\$5\$$salt\$"); +} + +# intended usage: convert_size($val, "kb" => "gb") +# we round up to the next integer by default +# E.g. `convert_size(1023, "b" => "kb")` returns 1 +# use $no_round_up to switch this off, above example would then return 0 +# this is also true for converting down e.g. 0.0005 gb to mb returns 1 +# (0 if $no_round_up is true) +# allowed formats for value: +# 1234 +# 1234. +# 1234.1234 +# .1234 +sub convert_size { + my ($value, $from, $to, $no_round_up) = @_; + + my $units = { + b => 0, + kb => 1, + mb => 2, + gb => 3, + tb => 4, + pb => 5, + }; + + die "no value given" + if !defined($value) || $value eq ""; + + $from = lc($from // ''); $to = lc($to // ''); + die "unknown 'from' and/or 'to' units ($from => $to)" + if !defined($units->{$from}) || !defined($units->{$to}); + + die "value '$value' is not a valid, positive number" + if $value !~ m/^(?:[0-9]+\.?[0-9]*|[0-9]*\.[0-9]+)$/; + + my $shift_amount = ($units->{$from} - $units->{$to}) * 10; + + $value *= 2**$shift_amount; + $value++ if !$no_round_up && ($value - int($value)) > 0.0; + + return int($value); +} + +# uninterruptible readline +# retries on EINTR +sub readline_nointr { + my ($fh) = @_; + my $line; + while (1) { + $line = <$fh>; + last if defined($line) || ($! != EINTR); + } + return $line; +} + +sub get_host_arch { + + my @uname = POSIX::uname(); + my $machine = $uname[4]; + + if ($machine eq 'x86_64') { + return 'amd64'; + } elsif ($machine eq 'aarch64') { + return 'arm64'; + } else { + die "unsupported host architecture '$machine'\n"; + } } 1;