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 $input;
 181         my $output;
 182         my $outfunc;
 183         my $errfunc;
 184         my $logfunc;
 185
 186         foreach my $p (keys %param) {
 187             if ($p eq 'timeout') {
 188                 $timeout = $param{$p};
 189             } elsif ($p eq 'umask') {
 190                 umask($param{$p});
 191             } elsif ($p eq 'errmsg') {
 192                 $errmsg = $param{$p};
 193                 $errfunc = sub {
 194                     print STDERR "$laststderr\n" if $laststderr;
 195                     $laststderr = shift;
 196                 };
 197             } elsif ($p eq 'input') {
 198                 $input = $param{$p};
 199             } elsif ($p eq 'output') {
 200                 $output = $param{$p};
 201             } elsif ($p eq 'outfunc') {
 202                 $outfunc = $param{$p};
 203             } elsif ($p eq 'errfunc') {
 204                 $errfunc = $param{$p};
 205             } elsif ($p eq 'logfunc') {
 206                 $logfunc = $param{$p};
 207             } else {
 208                 die "got unknown parameter '$p' for run_command\n";
 209             }
 210         }
 211
 212         my $reader = $output && $output =~ m/^>&/ ? $output : IO::File->new();
 213         my $writer = $input && $input =~ m/^<&/ ? $input : IO::File->new();
 214         my $error  = IO::File->new();
 215
 216         # try to avoid locale related issues/warnings
 217         my $lang = $param{lang} || 'C';
 218
 219         my $orig_pid = $$;
 220
 221         eval {
 222             local $ENV{LC_ALL} = $lang;
 223
 224             # suppress LVM warnings like: "File descriptor 3 left open";
 225             local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1";
 226
 227             $pid = open3($writer, $reader, $error, @$cmd) || die $!;
 228         };
 229
 230         my $err = $@;
 231
 232         # catch exec errors
 233         if ($orig_pid != $$) {
 234             warn "ERROR: $err";
 235             POSIX::_exit (1);
 236             kill ('KILL', $$);
 237         }
 238
 239         die $err if $err;
 240
 241         local $SIG{ALRM} = sub { die "got timeout\n"; } if $timeout;
 242         $oldtimeout = alarm($timeout) if $timeout;
 243
 244         print $writer $input if defined $input;
 245         close $writer;
 246
 247         my $select = new IO::Select;
 248         $select->add($reader);
 249         $select->add($error);
 250
 251         my $outlog = '';
 252         my $errlog = '';
 253
 254         my $starttime = time();
 255
 256         while ($select->count) {
 257             my @handles = $select->can_read(1);
 258
 259             foreach my $h (@handles) {
 260                 my $buf = '';
 261                 my $count = sysread ($h, $buf, 4096);
 262                 if (!defined ($count)) {
 263                     my $err = $!;
 264                     kill (9, $pid);
 265                     waitpid ($pid, 0);
 266                     die $err;
 267                 }
 268                 $select->remove ($h) if !$count;
 269                 if ($h eq $reader) {
 270                     if ($outfunc || $logfunc) {
 271                         eval {
 272                             $outlog .= $buf;
 273                             while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
 274                                 my $line = $1;
 275                                 &$outfunc($line) if $outfunc;
 276                                 &$logfunc($line) if $logfunc;
 277                             }
 278                         };
 279                         my $err = $@;
 280                         if ($err) {
 281                             kill (9, $pid);
 282                             waitpid ($pid, 0);
 283                             die $err;
 284                         }
 285                     } else {
 286                         print $buf;
 287                         *STDOUT->flush();
 288                     }
 289                 } elsif ($h eq $error) {
 290                     if ($errfunc || $logfunc) {
 291                         eval {
 292                             $errlog .= $buf;
 293                             while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
 294                                 my $line = $1;
 295                                 &$errfunc($line) if $errfunc;
 296                                 &$logfunc($line) if $logfunc;
 297                             }
 298                         };
 299                         my $err = $@;
 300                         if ($err) {
 301                             kill (9, $pid);
 302                             waitpid ($pid, 0);
 303                             die $err;
 304                         }
 305                     } else {
 306                         print STDERR $buf;
 307                         *STDERR->flush();
 308                     }
 309                 }
 310             }
 311         }
 312
 313         &$outfunc($outlog) if $outfunc && $outlog;
 314         &$logfunc($outlog) if $logfunc && $outlog;
 315
 316         &$errfunc($errlog) if $errfunc && $errlog;
 317         &$logfunc($errlog) if $logfunc && $errlog;
 318
 319         waitpid ($pid, 0);
 320
 321         if ($? == -1) {
 322             die "failed to execute\n";
 323         } elsif (my $sig = ($? & 127)) {
 324             die "got signal $sig\n";
 325         } elsif (my $ec = ($? >> 8)) {
 326             if (!($ec == 24 && ($cmdstr =~ m|^(\S+/)?rsync\s|))) {
 327                 if ($errmsg && $laststderr) {
 328                     my $lerr = $laststderr;
 329                     $laststderr = undef;
 330                     die "$lerr\n";
 331                 }
 332                 die "exit code $ec\n";
 333             }
 334         }
 335
 336         alarm(0);
 337     };
 338
 339     my $err = $@;
 340
 341     alarm(0);
 342
 343     print STDERR "$laststderr\n" if $laststderr;
 344
 345     umask ($old_umask) if defined($old_umask);
 346
 347     alarm($oldtimeout) if $oldtimeout;
 348
 349     if ($err) {
 350         if ($pid && ($err eq "got timeout\n")) {
 351             kill (9, $pid);
 352             waitpid ($pid, 0);
 353             die "command '$cmdstr' failed: $err";
 354         }
 355
 356         if ($errmsg) {
 357             die "$errmsg: $err";
 358         } else {
 359             die "command '$cmdstr' failed: $err";
 360         }
 361     }
 362
 363     return undef;
 364 }
 365
 366 sub split_list {
 367     my $listtxt = shift || '';
 368
 369     return split (/\0/, $listtxt) if $listtxt =~ m/\0/;
 370
 371     $listtxt =~ s/[,;]/ /g;
 372     $listtxt =~ s/^\s+//;
 373
 374     my @data = split (/\s+/, $listtxt);
 375
 376     return @data;
 377 }
 378
 379 sub trim {
 380     my $txt = shift;
 381
 382     return $txt if !defined($txt);
 383
 384     $txt =~ s/^\s+//;
 385     $txt =~ s/\s+$//;
 386
 387     return $txt;
 388 }
 389
 390 # simple uri templates like "/vms/{vmid}"
 391 sub template_replace {
 392     my ($tmpl, $data) = @_;
 393
 394     my $res = '';
 395     while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) {
 396         $res .= $1 if $1;
 397         $res .= ($data->{$3} || '-') if $2;
 398     }
 399     return $res;
 400 }
 401
 402 sub safe_print {
 403     my ($filename, $fh, $data) = @_;
 404
 405     return if !$data;
 406
 407     my $res = print $fh $data;
 408
 409     die "write to '$filename' failed\n" if !$res;
 410 }
 411
 412 sub debmirrors {
 413
 414     return {
 415         'at' => 'ftp.at.debian.org',
 416         'au' => 'ftp.au.debian.org',
 417         'be' => 'ftp.be.debian.org',
 418         'bg' => 'ftp.bg.debian.org',
 419         'br' => 'ftp.br.debian.org',
 420         'ca' => 'ftp.ca.debian.org',
 421         'ch' => 'ftp.ch.debian.org',
 422         'cl' => 'ftp.cl.debian.org',
 423         'cz' => 'ftp.cz.debian.org',
 424         'de' => 'ftp.de.debian.org',
 425         'dk' => 'ftp.dk.debian.org',
 426         'ee' => 'ftp.ee.debian.org',
 427         'es' => 'ftp.es.debian.org',
 428         'fi' => 'ftp.fi.debian.org',
 429         'fr' => 'ftp.fr.debian.org',
 430         'gr' => 'ftp.gr.debian.org',
 431         'hk' => 'ftp.hk.debian.org',
 432         'hr' => 'ftp.hr.debian.org',
 433         'hu' => 'ftp.hu.debian.org',
 434         'ie' => 'ftp.ie.debian.org',
 435         'is' => 'ftp.is.debian.org',
 436         'it' => 'ftp.it.debian.org',
 437         'jp' => 'ftp.jp.debian.org',
 438         'kr' => 'ftp.kr.debian.org',
 439         'mx' => 'ftp.mx.debian.org',
 440         'nl' => 'ftp.nl.debian.org',
 441         'no' => 'ftp.no.debian.org',
 442         'nz' => 'ftp.nz.debian.org',
 443         'pl' => 'ftp.pl.debian.org',
 444         'pt' => 'ftp.pt.debian.org',
 445         'ro' => 'ftp.ro.debian.org',
 446         'ru' => 'ftp.ru.debian.org',
 447         'se' => 'ftp.se.debian.org',
 448         'si' => 'ftp.si.debian.org',
 449         'sk' => 'ftp.sk.debian.org',
 450         'tr' => 'ftp.tr.debian.org',
 451         'tw' => 'ftp.tw.debian.org',
 452         'gb' => 'ftp.uk.debian.org',
 453         'us' => 'ftp.us.debian.org',
 454     };
 455 }
 456
 457 sub kvmkeymaps {
 458     return {
 459         'dk'     => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'],
 460         'de'     => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ],
 461         'de-ch'  => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz',  'ch', 'de_nodeadkeys' ],
 462         'en-gb'  => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', 'intl' ],
 463         'en-us'  => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz',  'us', 'intl' ],
 464         'es'     => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'],
 465         #'et'     => [], # Ethopia or Estonia ??
 466         'fi'     => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'],
 467         #'fo'     => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'],
 468         'fr'     => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'],
 469         'fr-be'  => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'],
 470         'fr-ca'  => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'],
 471         'fr-ch'  => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'],
 472         #'hr'     => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2?
 473         'hu'     => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef],
 474         'is'     => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'],
 475         'it'     => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'],
 476         'jp'     => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef],
 477         'lt'     => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'],
 478         #'lv'     => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7?
 479         'mk'     => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'],
 480         'nl'     => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef],
 481         #'nl-be'  => ['Belgium-Dutch', 'nl-be', ?, ?, ?],
 482         'no'   => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'],
 483         'pl'     => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef],
 484         'pt'     => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'],
 485         'pt-br'  => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'],
 486         #'ru'     => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know?
 487         'si'     => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef],
 488         #'sv'     => [], Swedish ?
 489         #'th'     => [],
 490         #'tr'     => [],
 491     };
 492 }
 493
 494 sub extract_param {
 495     my ($param, $key) = @_;
 496
 497     my $res = $param->{$key};
 498     delete $param->{$key};
 499
 500     return $res;
 501 }
 502
 503 sub next_vnc_port {
 504
 505     for (my $p = 5900; $p < 6000; $p++) {
 506
 507         my $sock = IO::Socket::INET->new (Listen => 5,
 508                                           LocalAddr => 'localhost',
 509                                           LocalPort => $p,
 510                                           ReuseAddr => 1,
 511                                           Proto     => 0);
 512
 513         if ($sock) {
 514             close ($sock);
 515             return $p;
 516         }
 517     }
 518
 519     die "unable to find free vnc port";
 520 };
 521
 522 # NOTE: NFS syscall can't be interrupted, so alarm does
 523 # not work to provide timeouts.
 524 # from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation"
 525 # So the spawn external 'df' process instead of using
 526 # Filesys::Df (which uses statfs syscall)
 527 sub df {
 528     my ($path, $timeout) = @_;
 529
 530     my $cmd = [ 'df', '-P', '-B', '1', $path];
 531
 532     my $res = {
 533         total => 0,
 534         used => 0,
 535         avail => 0,
 536     };
 537
 538     my $parser = sub {
 539         my $line = shift;
 540         if (my ($fsid, $total, $used, $avail) = $line =~
 541             m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) {
 542             $res = {
 543                 total => $total,
 544                 used => $used,
 545                 avail => $avail,
 546             };
 547         }
 548     };
 549     eval { run_command($cmd, timeout => $timeout, outfunc => $parser); };
 550     warn $@ if $@;
 551
 552     return $res;
 553 }
 554
 555 # UPID helper
 556 # We use this to uniquely identify a process.
 557 # An 'Unique Process ID' has the following format:
 558 # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
 559
 560 sub upid_encode {
 561     my $d = shift;
 562
 563     return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid},
 564                    $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id},
 565                    $d->{user});
 566 }
 567
 568 sub upid_decode {
 569     my ($upid, $noerr) = @_;
 570
 571     my $res;
 572     my $filename;
 573
 574     # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
 575     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]+):$/) {
 576         $res->{node} = $1;
 577         $res->{pid} = hex($2);
 578         $res->{pstart} = hex($3);
 579         $res->{starttime} = hex($4);
 580         $res->{type} = $5;
 581         $res->{id} = $6;
 582         $res->{user} = $7;
 583
 584         my $subdir = substr($4, 7, 8);
 585         $filename = "$pvetaskdir/$subdir/$upid";
 586
 587     } else {
 588         return undef if $noerr;
 589         die "unable to parse worker upid '$upid'\n";
 590     }
 591
 592     return wantarray ? ($res, $filename) : $res;
 593 }
 594
 595 sub upid_open {
 596     my ($upid) = @_;
 597
 598     my ($task, $filename) = upid_decode($upid);
 599
 600     my $dirname = dirname($filename);
 601     make_path($dirname);
 602
 603     my $wwwid = getpwnam('www-data') ||
 604         die "getpwnam failed";
 605
 606     my $perm = 0640;
 607
 608     my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) ||
 609         die "unable to create output file '$filename' - $!\n";
 610     chown $wwwid, $outfh;
 611
 612     return $outfh;
 613 };
 614
 615 sub upid_read_status {
 616     my ($upid) = @_;
 617
 618     my ($task, $filename) = upid_decode($upid);
 619     my $fh = IO::File->new($filename, "r");
 620     return "unable to open file - $!" if !$fh;
 621     my $maxlen = 1024;
 622     sysseek($fh, -$maxlen, 2);
 623     my $readbuf = '';
 624     my $br = sysread($fh, $readbuf, $maxlen);
 625     close($fh);
 626     if ($br) {
 627         return "unable to extract last line"
 628             if $readbuf !~ m/\n?(.+)$/;
 629         my $line = $1;
 630         if ($line =~ m/^TASK OK$/) {
 631             return 'OK';
 632         } elsif ($line =~ m/^TASK ERROR: (.+)$/) {
 633             return $1;
 634         } else {
 635             return "unexpected status";
 636         }
 637     }
 638     return "unable to read tail (got $br bytes)";
 639 }
 640
 641 # useful functions to store comments in config files
 642 sub encode_text {
 643     my ($text) = @_;
 644
 645     # all control and hi-bit characters, and ':'
 646     my $unsafe = "^\x20-\x39\x3b-\x7e";
 647     return uri_escape(Encode::encode("utf8", $text), $unsafe);
 648 }
 649
 650 sub decode_text {
 651     my ($data) = @_;
 652
 653     return Encode::decode("utf8", uri_unescape($data));
 654 }
 655
 656 sub random_ether_addr {
 657
 658     my $rand = Digest::SHA1::sha1_hex(rand(), time());
 659
 660     my $mac = '';
 661     for (my $i = 0; $i < 6; $i++) {
 662         my $ss = hex(substr($rand, $i*2, 2));
 663         if (!$i) {
 664             $ss &= 0xfe; # clear multicast
 665             $ss |= 2; # set local id
 666         }
 667         $ss = sprintf("%02X", $ss);
 668
 669         if (!$i) {
 670             $mac .= "$ss";
 671         } else {
 672             $mac .= ":$ss";
 673         }
 674     }
 675
 676     return $mac;
 677 }
 678
 679 1;