data/PVE/Tools.pm

   1 package PVE::Tools;
   2
   3 use strict;
   4 use POSIX;
   5 use IO::Socket::INET;
   6 use IO::Select;
   7 use File::Basename;
   8 use File::Path qw(make_path);
   9 use IO::File;
  10 use IPC::Open3;
  11 use Fcntl qw(:DEFAULT :flock);
  12 use base 'Exporter';
  13 use URI::Escape;
  14 use Encode;
  15 use Digest::SHA1;
  16
  17 our @EXPORT_OK = qw(
  18 lock_file
  19 run_command
  20 file_set_contents
  21 file_get_contents
  22 file_read_firstline
  23 split_list
  24 template_replace
  25 safe_print
  26 trim
  27 extract_param
  28 );
  29
  30 my $pvelogdir = "/var/log/pve";
  31 my $pvetaskdir = "$pvelogdir/tasks";
  32
  33 mkdir $pvelogdir;
  34 mkdir $pvetaskdir;
  35
  36 # flock: we use one file handle per process, so lock file
  37 # can be called multiple times and succeeds for the same process.
  38
  39 my $lock_handles =  {};
  40
  41 sub lock_file {
  42     my ($filename, $timeout, $code, @param) = @_;
  43
  44     my $res;
  45
  46     $timeout = 10 if !$timeout;
  47
  48     eval {
  49
  50         local $SIG{ALRM} = sub { die "got timeout (can't lock '$filename')\n"; };
  51
  52         alarm ($timeout);
  53
  54         if (!$lock_handles->{$$}->{$filename}) {
  55             $lock_handles->{$$}->{$filename} = new IO::File (">>$filename") ||
  56                 die "can't open lock file '$filename' - $!\n";
  57         }
  58
  59         if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX|LOCK_NB)) {
  60             print STDERR "trying to aquire lock...";
  61             if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX)) {
  62                 print STDERR " failed\n";
  63                 die "can't aquire lock for '$filename' - $!\n";
  64             }
  65             print STDERR " OK\n";
  66         }
  67         alarm (0);
  68
  69         $res = &$code(@param);
  70     };
  71
  72     my $err = $@;
  73
  74     alarm (0);
  75
  76     if ($lock_handles->{$$}->{$filename}) {
  77         my $fh = $lock_handles->{$$}->{$filename};
  78         $lock_handles->{$$}->{$filename} = undef;
  79         close ($fh);
  80     }
  81
  82     if ($err) {
  83         $@ = $err;
  84         return undef;
  85     }
  86
  87     $@ = undef;
  88
  89     return $res;
  90 }
  91
  92 sub file_set_contents {
  93     my ($filename, $data, $perm)  = @_;
  94
  95     $perm = 0644 if !defined($perm);
  96
  97     my $tmpname = "$filename.tmp.$$";
  98
  99     eval {
 100         my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm);
 101         die "unable to open file '$tmpname' - $!\n" if !$fh;
 102         die "unable to write '$tmpname' - $!\n" unless print $fh $data;
 103         die "closing file '$tmpname' failed - $!\n" unless close $fh;
 104     };
 105     my $err = $@;
 106
 107     if ($err) {
 108         unlink $tmpname;
 109         die $err;
 110     }
 111
 112     if (!rename($tmpname, $filename)) {
 113         my $msg = "close (rename) atomic file '$filename' failed: $!\n";
 114         unlink $tmpname;
 115         die $msg;
 116     }
 117 }
 118
 119 sub file_get_contents {
 120     my ($filename, $max) = @_;
 121
 122     my $fh = IO::File->new($filename, "r") ||
 123         die "can't open '$filename' - $!\n";
 124
 125     my $content = safe_read_from($fh, $max);
 126
 127     close $fh;
 128
 129     return $content;
 130 }
 131
 132 sub file_read_firstline {
 133     my ($filename) = @_;
 134
 135     my $fh = IO::File->new ($filename, "r");
 136     return undef if !$fh;
 137     my $res = <$fh>;
 138     chomp $res;
 139     $fh->close;
 140     return $res;
 141 }
 142
 143 sub safe_read_from {
 144     my ($fh, $max, $oneline) = @_;
 145
 146     $max = 32768 if !$max;
 147
 148     my $br = 0;
 149     my $input = '';
 150     my $count;
 151     while ($count = sysread($fh, $input, 8192, $br)) {
 152         $br += $count;
 153         die "input too long - aborting\n" if $br > $max;
 154         if ($oneline && $input =~ m/^(.*)\n/) {
 155             $input = $1;
 156             last;
 157         }
 158     }
 159     die "unable to read input - $!\n" if !defined($count);
 160
 161     return $input;
 162 }
 163
 164 sub run_command {
 165     my ($cmd, %param) = @_;
 166
 167     my $old_umask;
 168
 169     $cmd = [ $cmd ] if !ref($cmd);
 170
 171     my $cmdstr = join (' ', @$cmd);
 172
 173     my $errmsg;
 174     my $laststderr;
 175     my $timeout;
 176     my $oldtimeout;
 177     my $pid;
 178
 179     eval {
 180         my $reader = IO::File->new();
 181         my $writer = IO::File->new();
 182         my $error  = IO::File->new();
 183
 184         my $input;
 185         my $outfunc;
 186         my $errfunc;
 187
 188         foreach my $p (keys %param) {
 189             if ($p eq 'timeout') {
 190                 $timeout = $param{$p};
 191             } elsif ($p eq 'umask') {
 192                 umask($param{$p});
 193             } elsif ($p eq 'errmsg') {
 194                 $errmsg = $param{$p};
 195                 $errfunc = sub {
 196                     print STDERR "$laststderr\n" if $laststderr;
 197                     $laststderr = shift;
 198                 };
 199             } elsif ($p eq 'input') {
 200                 $input = $param{$p};
 201             } elsif ($p eq 'outfunc') {
 202                 $outfunc = $param{$p};
 203             } elsif ($p eq 'errfunc') {
 204                 $errfunc = $param{$p};
 205             } else {
 206                 die "got unknown parameter '$p' for run_command\n";
 207             }
 208         }
 209
 210         # try to avoid locale related issues/warnings
 211         my $lang = $param{lang} || 'C';
 212
 213         my $orig_pid = $$;
 214
 215         eval {
 216             local $ENV{LC_ALL} = $lang;
 217
 218             # suppress LVM warnings like: "File descriptor 3 left open";
 219             local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1";
 220
 221             $pid = open3($writer, $reader, $error, @$cmd) || die $!;
 222         };
 223
 224         my $err = $@;
 225
 226         # catch exec errors
 227         if ($orig_pid != $$) {
 228             warn "ERROR: $err";
 229             POSIX::_exit (1);
 230             kill ('KILL', $$);
 231         }
 232
 233         die $err if $err;
 234
 235         local $SIG{ALRM} = sub { die "got timeout\n"; } if $timeout;
 236         $oldtimeout = alarm($timeout) if $timeout;
 237
 238         print $writer $input if defined $input;
 239         close $writer;
 240
 241         my $select = new IO::Select;
 242         $select->add($reader);
 243         $select->add($error);
 244
 245         my $outlog = '';
 246         my $errlog = '';
 247
 248         my $starttime = time();
 249
 250         while ($select->count) {
 251             my @handles = $select->can_read(1);
 252
 253             foreach my $h (@handles) {
 254                 my $buf = '';
 255                 my $count = sysread ($h, $buf, 4096);
 256                 if (!defined ($count)) {
 257                     my $err = $!;
 258                     kill (9, $pid);
 259                     waitpid ($pid, 0);
 260                     die $err;
 261                 }
 262                 $select->remove ($h) if !$count;
 263                 if ($h eq $reader) {
 264                     if ($outfunc) {
 265                         eval {
 266                             $outlog .= $buf;
 267                             while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
 268                                 my $line = $1;
 269                                 &$outfunc($line);
 270                             }
 271                         };
 272                         my $err = $@;
 273                         if ($err) {
 274                             kill (9, $pid);
 275                             waitpid ($pid, 0);
 276                             die $err;
 277                         }
 278                     } else {
 279                         print $buf;
 280                         *STDOUT->flush();
 281                     }
 282                 } elsif ($h eq $error) {
 283                     if ($errfunc) {
 284                         eval {
 285                             $errlog .= $buf;
 286                             while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
 287                                 my $line = $1;
 288                                 &$errfunc($line);
 289                             }
 290                         };
 291                         my $err = $@;
 292                         if ($err) {
 293                             kill (9, $pid);
 294                             waitpid ($pid, 0);
 295                             die $err;
 296                         }
 297                     } else {
 298                         print STDERR $buf;
 299                         *STDERR->flush();
 300                     }
 301                 }
 302             }
 303         }
 304
 305         &$outfunc($outlog) if $outfunc && $outlog;
 306         &$errfunc($errlog) if $errfunc && $errlog;
 307
 308         waitpid ($pid, 0);
 309
 310         if ($? == -1) {
 311             die "failed to execute\n";
 312         } elsif (my $sig = ($? & 127)) {
 313             die "got signal $sig\n";
 314         } elsif (my $ec = ($? >> 8)) {
 315             if ($errmsg && $laststderr) {
 316                 my $lerr = $laststderr;
 317                 $laststderr = undef;
 318                 die "$lerr\n";
 319             }
 320             die "exit code $ec\n";
 321         }
 322
 323         alarm(0);
 324     };
 325
 326     my $err = $@;
 327
 328     alarm(0);
 329
 330     print STDERR "$laststderr\n" if $laststderr;
 331
 332     umask ($old_umask) if defined($old_umask);
 333
 334     alarm($oldtimeout) if $oldtimeout;
 335
 336     if ($err) {
 337         if ($pid && ($err eq "got timeout\n")) {
 338             kill (9, $pid);
 339             waitpid ($pid, 0);
 340             die "command '$cmdstr' failed: $err";
 341         }
 342
 343         if ($errmsg) {
 344             die "$errmsg: $err";
 345         } else {
 346             die "command '$cmdstr' failed: $err";
 347         }
 348     }
 349 }
 350
 351 sub split_list {
 352     my $listtxt = shift || '';
 353
 354     $listtxt =~ s/[,;\0]/ /g;
 355     $listtxt =~ s/^\s+//;
 356
 357     my @data = split (/\s+/, $listtxt);
 358
 359     return @data;
 360 }
 361
 362 sub trim {
 363     my $txt = shift;
 364
 365     return $txt if !defined($txt);
 366
 367     $txt =~ s/^\s+//;
 368     $txt =~ s/\s+$//;
 369
 370     return $txt;
 371 }
 372
 373 # simple uri templates like "/vms/{vmid}"
 374 sub template_replace {
 375     my ($tmpl, $data) = @_;
 376
 377     my $res = '';
 378     while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) {
 379         $res .= $1 if $1;
 380         $res .= ($data->{$3} || '-') if $2;
 381     }
 382     return $res;
 383 }
 384
 385 sub safe_print {
 386     my ($filename, $fh, $data) = @_;
 387
 388     return if !$data;
 389
 390     my $res = print $fh $data;
 391
 392     die "write to '$filename' failed\n" if !$res;
 393 }
 394
 395 sub debmirrors {
 396
 397     return {
 398         'at' => 'ftp.at.debian.org',
 399         'au' => 'ftp.au.debian.org',
 400         'be' => 'ftp.be.debian.org',
 401         'bg' => 'ftp.bg.debian.org',
 402         'br' => 'ftp.br.debian.org',
 403         'ca' => 'ftp.ca.debian.org',
 404         'ch' => 'ftp.ch.debian.org',
 405         'cl' => 'ftp.cl.debian.org',
 406         'cz' => 'ftp.cz.debian.org',
 407         'de' => 'ftp.de.debian.org',
 408         'dk' => 'ftp.dk.debian.org',
 409         'ee' => 'ftp.ee.debian.org',
 410         'es' => 'ftp.es.debian.org',
 411         'fi' => 'ftp.fi.debian.org',
 412         'fr' => 'ftp.fr.debian.org',
 413         'gr' => 'ftp.gr.debian.org',
 414         'hk' => 'ftp.hk.debian.org',
 415         'hr' => 'ftp.hr.debian.org',
 416         'hu' => 'ftp.hu.debian.org',
 417         'ie' => 'ftp.ie.debian.org',
 418         'is' => 'ftp.is.debian.org',
 419         'it' => 'ftp.it.debian.org',
 420         'jp' => 'ftp.jp.debian.org',
 421         'kr' => 'ftp.kr.debian.org',
 422         'mx' => 'ftp.mx.debian.org',
 423         'nl' => 'ftp.nl.debian.org',
 424         'no' => 'ftp.no.debian.org',
 425         'nz' => 'ftp.nz.debian.org',
 426         'pl' => 'ftp.pl.debian.org',
 427         'pt' => 'ftp.pt.debian.org',
 428         'ro' => 'ftp.ro.debian.org',
 429         'ru' => 'ftp.ru.debian.org',
 430         'se' => 'ftp.se.debian.org',
 431         'si' => 'ftp.si.debian.org',
 432         'sk' => 'ftp.sk.debian.org',
 433         'tr' => 'ftp.tr.debian.org',
 434         'tw' => 'ftp.tw.debian.org',
 435         'gb' => 'ftp.uk.debian.org',
 436         'us' => 'ftp.us.debian.org',
 437     };
 438 }
 439
 440 sub kvmkeymaps {
 441     return {
 442         'dk'     => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'],
 443         'de'     => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ],
 444         'de-ch'  => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz',  'ch', 'de_nodeadkeys' ],
 445         'en-gb'  => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', 'intl' ],
 446         'en-us'  => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz',  'us', 'intl' ],
 447         'es'     => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'],
 448         #'et'     => [], # Ethopia or Estonia ??
 449         'fi'     => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'],
 450         #'fo'     => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'],
 451         'fr'     => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'],
 452         'fr-be'  => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'],
 453         'fr-ca'  => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'],
 454         'fr-ch'  => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'],
 455         #'hr'     => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2?
 456         'hu'     => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef],
 457         'is'     => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'],
 458         'it'     => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'],
 459         'jp'     => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef],
 460         'lt'     => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'],
 461         #'lv'     => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7?
 462         'mk'     => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'],
 463         'nl'     => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef],
 464         #'nl-be'  => ['Belgium-Dutch', 'nl-be', ?, ?, ?],
 465         'no'   => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'],
 466         'pl'     => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef],
 467         'pt'     => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'],
 468         'pt-br'  => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'],
 469         #'ru'     => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know?
 470         'si'     => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef],
 471         #'sv'     => [], Swedish ?
 472         #'th'     => [],
 473         #'tr'     => [],
 474     };
 475 }
 476
 477 sub extract_param {
 478     my ($param, $key) = @_;
 479
 480     my $res = $param->{$key};
 481     delete $param->{$key};
 482
 483     return $res;
 484 }
 485
 486 sub next_vnc_port {
 487
 488     for (my $p = 5900; $p < 6000; $p++) {
 489
 490         my $sock = IO::Socket::INET->new (Listen => 5,
 491                                           LocalAddr => 'localhost',
 492                                           LocalPort => $p,
 493                                           ReuseAddr => 1,
 494                                           Proto     => 0);
 495
 496         if ($sock) {
 497             close ($sock);
 498             return $p;
 499         }
 500     }
 501
 502     die "unable to find free vnc port";
 503 };
 504
 505 # NOTE: NFS syscall can't be interrupted, so alarm does
 506 # not work to provide timeouts.
 507 # from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation"
 508 # So the spawn external 'df' process instead of using
 509 # Filesys::Df (which uses statfs syscall)
 510 sub df {
 511     my ($path, $timeout) = @_;
 512
 513     my $cmd = [ 'df', '-P', '-B', '1', $path];
 514
 515     my $res = {
 516         total => 0,
 517         used => 0,
 518         avail => 0,
 519     };
 520
 521     my $parser = sub {
 522         my $line = shift;
 523         if (my ($fsid, $total, $used, $avail) = $line =~
 524             m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) {
 525             $res = {
 526                 total => $total,
 527                 used => $used,
 528                 avail => $avail,
 529             };
 530         }
 531     };
 532     eval { run_command($cmd, timeout => $timeout, outfunc => $parser); };
 533     warn $@ if $@;
 534
 535     return $res;
 536 }
 537
 538 # UPID helper
 539 # We use this to uniquely identify a process.
 540 # An 'Unique Process ID' has the following format:
 541 # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
 542
 543 sub upid_encode {
 544     my $d = shift;
 545
 546     return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid},
 547                    $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id},
 548                    $d->{user});
 549 }
 550
 551 sub upid_decode {
 552     my ($upid, $noerr) = @_;
 553
 554     my $res;
 555     my $filename;
 556
 557     # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
 558     if ($upid =~ m/^UPID:([A-Za-z][[:alnum:]\-]*[[:alnum:]]+):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8}):([^:\s]+):([^:\s]*):([^:\s]+):$/) {
 559         $res->{node} = $1;
 560         $res->{pid} = hex($2);
 561         $res->{pstart} = hex($3);
 562         $res->{starttime} = hex($4);
 563         $res->{type} = $5;
 564         $res->{id} = $6;
 565         $res->{user} = $7;
 566
 567         my $subdir = substr($4, 7, 8);
 568         $filename = "$pvetaskdir/$subdir/$upid";
 569
 570     } else {
 571         return undef if $noerr;
 572         die "unable to parse worker upid '$upid'\n";
 573     }
 574
 575     return wantarray ? ($res, $filename) : $res;
 576 }
 577
 578 sub upid_open {
 579     my ($upid) = @_;
 580
 581     my ($task, $filename) = upid_decode($upid);
 582
 583     my $dirname = dirname($filename);
 584     make_path($dirname);
 585
 586     my $wwwid = getpwnam('www-data') ||
 587         die "getpwnam failed";
 588
 589     my $perm = 0640;
 590
 591     my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) ||
 592         die "unable to create output file '$filename' - $!\n";
 593     chown $wwwid, $outfh;
 594
 595     return $outfh;
 596 };
 597
 598 sub upid_read_status {
 599     my ($upid) = @_;
 600
 601     my ($task, $filename) = upid_decode($upid);
 602     my $fh = IO::File->new($filename, "r");
 603     return "unable to open file - $!" if !$fh;
 604     my $maxlen = 1024;
 605     sysseek($fh, -$maxlen, 2);
 606     my $readbuf = '';
 607     my $br = sysread($fh, $readbuf, $maxlen);
 608     close($fh);
 609     if ($br) {
 610         return "unable to extract last line"
 611             if $readbuf !~ m/\n?(.+)$/;
 612         my $line = $1;
 613         if ($line =~ m/^TASK OK$/) {
 614             return 'OK';
 615         } elsif ($line =~ m/^TASK ERROR: (.+)$/) {
 616             return $1;
 617         } else {
 618             return "unexpected status";
 619         }
 620     }
 621     return "unable to read tail (got $br bytes)";
 622 }
 623
 624 # useful functions to store comments in config files
 625 sub encode_text {
 626     my ($text) = @_;
 627
 628     # all control and hi-bit characters, and ':'
 629     my $unsafe = "^\x20-\x39\x3b-\x7e";
 630     return uri_escape(Encode::encode("utf8", $text), $unsafe);
 631 }
 632
 633 sub decode_text {
 634     my ($data) = @_;
 635
 636     return Encode::decode("utf8", uri_unescape($data));
 637 }
 638
 639 sub random_ether_addr {
 640
 641     my $rand = Digest::SHA1::sha1_hex(rand(), time());
 642
 643     my $mac = '';
 644     for (my $i = 0; $i < 6; $i++) {
 645         my $ss = hex(substr($rand, $i*2, 2));
 646         if (!$i) {
 647             $ss &= 0xfe; # clear multicast
 648             $ss |= 2; # set local id
 649         }
 650         $ss = sprintf("%02X", $ss);
 651
 652         if (!$i) {
 653             $mac .= "$ss";
 654         } else {
 655             $mac .= ":$ss";
 656         }
 657     }
 658
 659     return $mac;
 660 }
 661
 662 1;