PMG/Utils.pm

   1 package PMG::Utils;
   2
   3 use strict;
   4 use warnings;
   5 use DBI;
   6 use Net::Cmd;
   7 use Net::SMTP;
   8 use IO::File;
   9 use File::stat;
  10 use POSIX qw(strftime);
  11 use File::stat;
  12 use File::Basename;
  13 use MIME::Words;
  14 use MIME::Parser;
  15 use Time::HiRes qw (gettimeofday);
  16 use Xdgmime;
  17 use Data::Dumper;
  18 use Digest::SHA;
  19 use Net::IP;
  20 use Socket;
  21 use RRDs;
  22 use Filesys::Df;
  23 use Encode;
  24 use HTML::Entities;
  25
  26 use PVE::ProcFSTools;
  27 use PVE::Network;
  28 use PVE::Tools;
  29 use PVE::SafeSyslog;
  30 use PVE::ProcFSTools;
  31 use PMG::AtomicFile;
  32 use PMG::MailQueue;
  33 use PMG::SMTPPrinter;
  34
  35 my $realm_regex = qr/[A-Za-z][A-Za-z0-9\.\-_]+/;
  36
  37 PVE::JSONSchema::register_format('pmg-realm', \&verify_realm);
  38 sub verify_realm {
  39     my ($realm, $noerr) = @_;
  40
  41     if ($realm !~ m/^${realm_regex}$/) {
  42         return undef if $noerr;
  43         die "value does not look like a valid realm\n";
  44     }
  45     return $realm;
  46 }
  47
  48 PVE::JSONSchema::register_standard_option('realm', {
  49     description => "Authentication domain ID",
  50     type => 'string', format => 'pmg-realm',
  51     maxLength => 32,
  52 });
  53
  54 PVE::JSONSchema::register_format('pmg-userid', \&verify_username);
  55 sub verify_username {
  56     my ($username, $noerr) = @_;
  57
  58     $username = '' if !$username;
  59     my $len = length($username);
  60     if ($len < 3) {
  61         die "user name '$username' is too short\n" if !$noerr;
  62         return undef;
  63     }
  64     if ($len > 64) {
  65         die "user name '$username' is too long ($len > 64)\n" if !$noerr;
  66         return undef;
  67     }
  68
  69     # we only allow a limited set of characters
  70     # colon is not allowed, because we store usernames in
  71     # colon separated lists)!
  72     # slash is not allowed because it is used as pve API delimiter
  73     # also see "man useradd"
  74     if ($username =~ m!^([^\s:/]+)\@(${realm_regex})$!) {
  75         return wantarray ? ($username, $1, $2) : $username;
  76     }
  77
  78     die "value '$username' does not look like a valid user name\n" if !$noerr;
  79
  80     return undef;
  81 }
  82
  83 PVE::JSONSchema::register_standard_option('userid', {
  84     description => "User ID",
  85     type => 'string', format => 'pmg-userid',
  86     minLength => 4,
  87     maxLength => 64,
  88 });
  89
  90 PVE::JSONSchema::register_standard_option('username', {
  91     description => "Username (without realm)",
  92     type => 'string',
  93     pattern => '[^\s:\/\@]{3,60}',
  94     minLength => 4,
  95     maxLength => 64,
  96 });
  97
  98 sub lastid {
  99     my ($dbh, $seq) = @_;
 100
 101     return $dbh->last_insert_id(
 102         undef, undef, undef, undef, { sequence => $seq});
 103 }
 104
 105 # quote all regex operators
 106 sub quote_regex {
 107     my $val = shift;
 108
 109     $val =~ s/([\(\)\[\]\/\}\+\*\?\.\|\^\$\\])/\\$1/g;
 110
 111     return $val;
 112 }
 113
 114 sub file_older_than {
 115     my ($filename, $lasttime) = @_;
 116
 117     my $st = stat($filename);
 118
 119     return 0 if !defined($st);
 120
 121     return ($lasttime >= $st->ctime);
 122 }
 123
 124 sub extract_filename {
 125     my ($head) = @_;
 126
 127     if (my $value = $head->recommended_filename()) {
 128         chomp $value;
 129         if (my $decvalue = MIME::Words::decode_mimewords($value)) {
 130             $decvalue =~ s/\0/ /g;
 131             $decvalue = PVE::Tools::trim($decvalue);
 132             return $decvalue;
 133         }
 134     }
 135
 136     return undef;
 137 }
 138
 139 sub remove_marks {
 140     my ($entity, $add_id, $id) = @_;
 141
 142     $id //= 1;
 143
 144     foreach my $tag (grep {/^x-proxmox-tmp/i} $entity->head->tags) {
 145         $entity->head->delete ($tag);
 146     }
 147
 148     $entity->head->replace('X-Proxmox-tmp-AID', $id) if $add_id;
 149
 150     foreach my $part ($entity->parts)  {
 151         $id = remove_marks($part, $add_id, $id + 1);
 152     }
 153
 154     return $id;
 155 }
 156
 157 sub subst_values {
 158     my ($body, $dh) = @_;
 159
 160     return if !$body;
 161
 162     foreach my $k (keys %$dh) {
 163         my $v = $dh->{$k};
 164         if (defined($v)) {
 165             $body =~ s/__\Q${k}\E__/$v/gs;
 166         }
 167     }
 168
 169     return $body;
 170 }
 171
 172 sub reinject_mail {
 173     my ($entity, $sender, $targets, $xforward, $me, $nodsn) = @_;
 174
 175     my $smtp;
 176     my $resid;
 177     my $rescode;
 178     my $resmess;
 179
 180     eval {
 181         my $smtp = Net::SMTP->new('127.0.0.1', Port => 10025, Hello => $me) ||
 182             die "unable to connect to localhost at port 10025";
 183
 184         if (defined($xforward)) {
 185             my $xfwd;
 186
 187             foreach my $attr (keys %{$xforward}) {
 188                 $xfwd .= " $attr=$xforward->{$attr}";
 189             }
 190
 191             if ($xfwd && $smtp->command("XFORWARD", $xfwd)->response() != CMD_OK) {
 192                 syslog('err', "xforward error - got: %s %s", $smtp->code, scalar($smtp->message));
 193             }
 194         }
 195
 196         if (!$smtp->mail($sender)) {
 197             syslog('err', "smtp error - got: %s %s", $smtp->code, scalar ($smtp->message));
 198             die "smtp from: ERROR";
 199         }
 200
 201         my $dsnopts = $nodsn ? {Notify => ['NEVER']} : {};
 202
 203         if (!$smtp->to (@$targets, $dsnopts)) {
 204             syslog ('err', "smtp error - got: %s %s", $smtp->code, scalar($smtp->message));
 205             die "smtp to: ERROR";
 206         }
 207
 208         # Output the head:
 209         #$entity->sync_headers ();
 210         $smtp->data();
 211
 212         my $out = PMG::SMTPPrinter->new($smtp);
 213         $entity->print($out);
 214
 215         # make sure we always have a newline at the end of the mail
 216         # else dataend() fails
 217         $smtp->datasend("\n");
 218
 219         if ($smtp->dataend()) {
 220             my @msgs = $smtp->message;
 221             $resmess = $msgs[$#msgs];
 222             ($resid) = $resmess =~ m/Ok: queued as ([0-9A-Z]+)/;
 223             $rescode = $smtp->code;
 224             if (!$resid) {
 225                 die sprintf("unexpected SMTP result - got: %s %s : WARNING", $smtp->code, $resmess);
 226             }
 227         } else {
 228             my @msgs = $smtp->message;
 229             $resmess = $msgs[$#msgs];
 230             $rescode = $smtp->code;
 231             die sprintf("sending data failed - got: %s %s : ERROR", $smtp->code, $resmess);
 232         }
 233     };
 234     my $err = $@;
 235
 236     $smtp->quit if $smtp;
 237
 238     if ($err) {
 239         syslog ('err', $err);
 240     }
 241
 242     return wantarray ? ($resid, $rescode, $resmess) : $resid;
 243 }
 244
 245 sub analyze_virus_clam {
 246     my ($queue, $dname, $pmg_cfg) = @_;
 247
 248     my $timeout = 60*5;
 249     my $vinfo;
 250
 251     my $clamdscan_opts = "--stdout";
 252
 253     my ($csec, $usec) = gettimeofday();
 254
 255     my $previous_alarm;
 256
 257     eval {
 258
 259         $previous_alarm = alarm($timeout);
 260
 261         $SIG{ALRM} = sub {
 262             die "$queue->{logid}: Maximum time ($timeout sec) exceeded. " .
 263                 "virus analyze (clamav) failed: ERROR";
 264         };
 265
 266         open(CMD, "/usr/bin/clamdscan $clamdscan_opts '$dname'|") ||
 267             die "$queue->{logid}: can't exec clamdscan: $! : ERROR";
 268
 269         my $ifiles;
 270
 271         my $response = '';
 272         while (defined(my $line = <CMD>)) {
 273             if ($line =~ m/^$dname.*:\s+([^ :]*)\s+FOUND$/) {
 274                 # we just use the first detected virus name
 275                 $vinfo = $1 if !$vinfo;
 276             } elsif ($line =~ m/^Infected files:\s(\d*)$/i) {
 277                 $ifiles = $1;
 278             }
 279
 280             $response .= $line;
 281         }
 282
 283         close(CMD);
 284
 285         alarm(0); # avoid race conditions
 286
 287         if (!defined($ifiles)) {
 288             die "$queue->{logid}: got undefined output from " .
 289                 "virus detector: $response : ERROR";
 290         }
 291
 292         if ($vinfo) {
 293             syslog('info', "$queue->{logid}: virus detected: $vinfo (clamav)");
 294         }
 295     };
 296     my $err = $@;
 297
 298     alarm($previous_alarm);
 299
 300     my ($csec_end, $usec_end) = gettimeofday();
 301     $queue->{ptime_clam} =
 302         int (($csec_end-$csec)*1000 + ($usec_end - $usec)/1000);
 303
 304     if ($err) {
 305         syslog ('err', $err);
 306         $vinfo = undef;
 307         $queue->{errors} = 1;
 308     }
 309
 310     $queue->{vinfo_clam} = $vinfo;
 311
 312     return $vinfo ? "$vinfo (clamav)" : undef;
 313 }
 314
 315 sub analyze_virus {
 316     my ($queue, $filename, $pmg_cfg, $testmode) = @_;
 317
 318     # TODO: support other virus scanners?
 319
 320     # always scan with clamav
 321     return analyze_virus_clam($queue, $filename, $pmg_cfg);
 322 }
 323
 324 sub magic_mime_type_for_file {
 325     my ($filename) = @_;
 326
 327     # we do not use get_mime_type_for_file, because that considers
 328     # filename extensions - we only want magic type detection
 329
 330     my $bufsize = Xdgmime::xdg_mime_get_max_buffer_extents();
 331     die "got strange value for max_buffer_extents" if $bufsize > 4096*10;
 332
 333     my $ct = "application/octet-stream";
 334
 335     my $fh = IO::File->new("<$filename") ||
 336         die "unable to open file '$filename' - $!";
 337
 338     my ($buf, $len);
 339     if (($len = $fh->read($buf, $bufsize)) > 0) {
 340         $ct = xdg_mime_get_mime_type_for_data($buf, $len);
 341     }
 342     $fh->close();
 343
 344     die "unable to read file '$filename' - $!" if ($len < 0);
 345
 346     return $ct;
 347 }
 348
 349 sub add_ct_marks {
 350     my ($entity) = @_;
 351
 352     if (my $path = $entity->{PMX_decoded_path}) {
 353
 354         # set a reasonable default if magic does not give a result
 355         $entity->{PMX_magic_ct} = $entity->head->mime_attr('content-type');
 356
 357         if (my $ct = magic_mime_type_for_file($path)) {
 358             if ($ct ne 'application/octet-stream' || !$entity->{PMX_magic_ct}) {
 359                 $entity->{PMX_magic_ct} = $ct;
 360             }
 361         }
 362
 363         my $filename = $entity->head->recommended_filename;
 364         $filename = basename($path) if !defined($filename) || $filename eq '';
 365
 366         if (my $ct = xdg_mime_get_mime_type_from_file_name($filename)) {
 367             $entity->{PMX_glob_ct} = $ct;
 368         }
 369     }
 370
 371     foreach my $part ($entity->parts)  {
 372         add_ct_marks ($part);
 373     }
 374 }
 375
 376 # x509 certificate utils
 377
 378 # only write output if something fails
 379 sub run_silent_cmd {
 380     my ($cmd) = @_;
 381
 382     my $outbuf = '';
 383
 384     my $record_output = sub {
 385         $outbuf .= shift;
 386         $outbuf .= "\n";
 387     };
 388
 389     eval {
 390         PVE::Tools::run_command($cmd, outfunc => $record_output,
 391                                 errfunc => $record_output);
 392     };
 393     my $err = $@;
 394
 395     if ($err) {
 396         print STDERR $outbuf;
 397         die $err;
 398     }
 399 }
 400
 401 my $proxmox_tls_cert_fn = "/etc/pmg/pmg-tls.pem";
 402
 403 sub gen_proxmox_tls_cert {
 404     my ($force) = @_;
 405
 406     my $resolv = PVE::INotify::read_file('resolvconf');
 407     my $domain = $resolv->{search};
 408
 409     my $company = $domain; # what else ?
 410     my $cn = "*.$domain";
 411
 412    return if !$force && -f $proxmox_tls_cert_fn;
 413
 414     my $sslconf = <<__EOD__;
 415 RANDFILE = /root/.rnd
 416 extensions = v3_req
 417
 418 [ req ]
 419 default_bits = 4096
 420 distinguished_name = req_distinguished_name
 421 req_extensions = v3_req
 422 prompt = no
 423 string_mask = nombstr
 424
 425 [ req_distinguished_name ]
 426 organizationalUnitName = Proxmox Mail Gateway
 427 organizationName = $company
 428 commonName = $cn
 429
 430 [ v3_req ]
 431 basicConstraints = CA:FALSE
 432 nsCertType = server
 433 keyUsage = nonRepudiation, digitalSignature, keyEncipherment
 434 __EOD__
 435
 436     my $cfgfn = "/tmp/pmgtlsconf-$$.tmp";
 437     my $fh = IO::File->new ($cfgfn, "w");
 438     print $fh $sslconf;
 439     close ($fh);
 440
 441     eval {
 442         my $cmd = ['openssl', 'req', '-batch', '-x509', '-new', '-sha256',
 443                    '-config', $cfgfn, '-days', 3650, '-nodes',
 444                    '-out', $proxmox_tls_cert_fn,
 445                    '-keyout', $proxmox_tls_cert_fn];
 446         run_silent_cmd($cmd);
 447     };
 448
 449     if (my $err = $@) {
 450         unlink $proxmox_tls_cert_fn;
 451         unlink $cfgfn;
 452         die "unable to generate proxmox certificate request:\n$err";
 453     }
 454
 455     unlink $cfgfn;
 456 }
 457
 458 sub find_local_network_for_ip {
 459     my ($ip) = @_;
 460
 461     my $testip = Net::IP->new($ip);
 462
 463     my $isv6 = $testip->version == 6;
 464     my $routes = $isv6 ?
 465         PVE::ProcFSTools::read_proc_net_ipv6_route() :
 466         PVE::ProcFSTools::read_proc_net_route();
 467
 468     foreach my $entry (@$routes) {
 469         my $mask;
 470         if ($isv6) {
 471             $mask = $entry->{prefix};
 472             next if !$mask; # skip the default route...
 473         } else {
 474             $mask = $PVE::Network::ipv4_mask_hash_localnet->{$entry->{mask}};
 475             next if !defined($mask);
 476         }
 477         my $cidr = "$entry->{dest}/$mask";
 478         my $testnet = Net::IP->new($cidr);
 479         my $overlap = $testnet->overlaps($testip);
 480         if ($overlap == $Net::IP::IP_B_IN_A_OVERLAP ||
 481             $overlap == $Net::IP::IP_IDENTICAL)
 482         {
 483             return $cidr;
 484         }
 485     }
 486
 487     die "unable to detect local network for ip '$ip'\n";
 488 }
 489
 490 my $service_aliases = {
 491     'postfix' =>  'postfix@-',
 492     'postgres' => 'postgresql@9.6-main',
 493 };
 494
 495 sub lookup_real_service_name {
 496     my $alias = shift;
 497
 498     return $service_aliases->{$alias} // $alias;
 499 }
 500
 501 sub get_full_service_state {
 502     my ($service) = @_;
 503
 504     my $res;
 505
 506     my $parser = sub {
 507         my $line = shift;
 508         if ($line =~ m/^([^=\s]+)=(.*)$/) {
 509             $res->{$1} = $2;
 510         }
 511     };
 512
 513     $service = $service_aliases->{$service} // $service;
 514     PVE::Tools::run_command(['systemctl', 'show', $service], outfunc => $parser);
 515
 516     return $res;
 517 }
 518
 519 sub service_wait_stopped {
 520     my ($timeout, $service_list) = @_;
 521
 522     my $starttime = time();
 523
 524     foreach my $service (@$service_list) {
 525         PVE::Tools::run_command(['systemctl', 'stop', $service]);
 526     }
 527
 528     while (1) {
 529         my $wait = 0;
 530
 531         foreach my $service (@$service_list) {
 532             my $ss = get_full_service_state($service);
 533             my $state = $ss->{ActiveState} // 'unknown';
 534
 535             if ($state ne 'inactive') {
 536                 if ((time() - $starttime) > $timeout) {
 537                     syslog('err', "unable to stop services (got timeout)");
 538                     $wait = 0;
 539                     last;
 540                 }
 541                 $wait = 1;
 542             }
 543         }
 544
 545         last if !$wait;
 546
 547         sleep(1);
 548     }
 549 }
 550
 551 sub service_cmd {
 552     my ($service, $cmd) = @_;
 553
 554     die "unknown service command '$cmd'\n"
 555         if $cmd !~ m/^(start|stop|restart|reload)$/;
 556
 557     if ($service eq 'pmgdaemon' || $service eq 'pmgproxy') {
 558         if ($cmd eq 'restart') {
 559             # OK
 560         } else {
 561             die "invalid service cmd '$service $cmd': ERROR";
 562         }
 563     }
 564
 565     $service = $service_aliases->{$service} // $service;
 566     PVE::Tools::run_command(['systemctl', $cmd, $service]);
 567 };
 568
 569 # this is also used to get the IP of the local node
 570 sub lookup_node_ip {
 571     my ($nodename, $noerr) = @_;
 572
 573     my ($family, $packed_ip);
 574
 575     eval {
 576         my @res = PVE::Tools::getaddrinfo_all($nodename);
 577         $family = $res[0]->{family};
 578         $packed_ip = (PVE::Tools::unpack_sockaddr_in46($res[0]->{addr}))[2];
 579     };
 580
 581     if ($@) {
 582         die "hostname lookup failed:\n$@" if !$noerr;
 583         return undef;
 584     }
 585
 586     my $ip = Socket::inet_ntop($family, $packed_ip);
 587     if ($ip =~ m/^127\.|^::1$/) {
 588         die "hostname lookup failed - got local IP address ($nodename = $ip)\n" if !$noerr;
 589         return undef;
 590     }
 591
 592     return wantarray ? ($ip, $family) : $ip;
 593 }
 594
 595 sub run_postmap {
 596     my ($filename) = @_;
 597
 598     # make sure the file exists (else postmap fails)
 599     IO::File->new($filename, 'a', 0644);
 600
 601     eval {
 602         PVE::Tools::run_command(
 603             ['/usr/sbin/postmap', $filename],
 604             errmsg => "unable to update postfix table $filename");
 605     };
 606     my $err = $@;
 607
 608     warn $err if $err;
 609 }
 610
 611 sub clamav_dbstat {
 612
 613     my $res = [];
 614
 615     my $read_cvd_info = sub {
 616         my ($dbname, $dbfile) = @_;
 617
 618         my $header;
 619         my $fh = IO::File->new("<$dbfile");
 620         if (!$fh) {
 621             warn "cant open ClamAV Database $dbname ($dbfile) - $!\n";
 622             return;
 623         }
 624         $fh->read($header, 512);
 625         $fh->close();
 626
 627         ## ClamAV-VDB:16 Mar 2016 23-17 +0000:57:4218790:60:06386f34a16ebeea2733ab037f0536be:
 628         if ($header =~ m/^(ClamAV-VDB):([^:]+):(\d+):(\d+):/) {
 629             my ($ftype, $btime, $version, $nsigs) = ($1, $2, $3, $4);
 630             push @$res, {
 631                 name => $dbname,
 632                 type => $ftype,
 633                 build_time => $btime,
 634                 version => $version,
 635                 nsigs => $nsigs,
 636             };
 637         } else {
 638             warn "unable to parse ClamAV Database $dbname ($dbfile)\n";
 639         }
 640     };
 641
 642     # main database
 643     my $filename = "/var/lib/clamav/main.inc/main.info";
 644     $filename = "/var/lib/clamav/main.cvd" if ! -f $filename;
 645
 646     $read_cvd_info->('main', $filename) if -f $filename;
 647
 648     # daily database
 649     $filename = "/var/lib/clamav/daily.inc/daily.info";
 650     $filename = "/var/lib/clamav/daily.cvd" if ! -f $filename;
 651     $filename = "/var/lib/clamav/daily.cld" if ! -f $filename;
 652
 653     $read_cvd_info->('daily', $filename) if -f $filename;
 654
 655     $filename = "/var/lib/clamav/bytecode.cvd";
 656     $read_cvd_info->('bytecode', $filename) if -f $filename;
 657
 658     $filename = "/var/lib/clamav/safebrowsing.cvd";
 659     $read_cvd_info->('safebrowsing', $filename) if -f $filename;
 660
 661     my $ss_dbs_fn = "/var/lib/clamav-unofficial-sigs/configs/ss-include-dbs.txt";
 662     my $ss_dbs_files = {};
 663     if (my $ssfh = IO::File->new("<${ss_dbs_fn}")) {
 664         while (defined(my $line = <$ssfh>)) {
 665             chomp $line;
 666             $ss_dbs_files->{$line} = 1;
 667         }
 668     }
 669     my $last = 0;
 670     my $nsigs = 0;
 671     foreach $filename (</var/lib/clamav/*>) {
 672         my $fn = basename($filename);
 673         next if !$ss_dbs_files->{$fn};
 674
 675         my $fh = IO::File->new("<$filename");
 676         next if !defined($fh);
 677         my $st = stat($fh);
 678         next if !$st;
 679         my $mtime = $st->mtime();
 680         $last = $mtime if $mtime > $last;
 681         while (defined(my $line = <$fh>)) { $nsigs++; }
 682     }
 683
 684     if ($nsigs > 0) {
 685         push @$res, {
 686             name => 'sanesecurity',
 687             type => 'unofficial',
 688             build_time => strftime("%d %b %Y %H-%M %z", localtime($last)),
 689             nsigs => $nsigs,
 690         };
 691     }
 692
 693     return $res;
 694 }
 695
 696 # RRD related code
 697 my $rrd_dir = "/var/lib/rrdcached/db";
 698 my $rrdcached_socket = "/var/run/rrdcached.sock";
 699
 700 my $rrd_def_node = [
 701     "DS:loadavg:GAUGE:120:0:U",
 702     "DS:maxcpu:GAUGE:120:0:U",
 703     "DS:cpu:GAUGE:120:0:U",
 704     "DS:iowait:GAUGE:120:0:U",
 705     "DS:memtotal:GAUGE:120:0:U",
 706     "DS:memused:GAUGE:120:0:U",
 707     "DS:swaptotal:GAUGE:120:0:U",
 708     "DS:swapused:GAUGE:120:0:U",
 709     "DS:roottotal:GAUGE:120:0:U",
 710     "DS:rootused:GAUGE:120:0:U",
 711     "DS:netin:DERIVE:120:0:U",
 712     "DS:netout:DERIVE:120:0:U",
 713
 714     "RRA:AVERAGE:0.5:1:70", # 1 min avg - one hour
 715     "RRA:AVERAGE:0.5:30:70", # 30 min avg - one day
 716     "RRA:AVERAGE:0.5:180:70", # 3 hour avg - one week
 717     "RRA:AVERAGE:0.5:720:70", # 12 hour avg - one month
 718     "RRA:AVERAGE:0.5:10080:70", # 7 day avg - ony year
 719
 720     "RRA:MAX:0.5:1:70", # 1 min max - one hour
 721     "RRA:MAX:0.5:30:70", # 30 min max - one day
 722     "RRA:MAX:0.5:180:70", # 3 hour max - one week
 723     "RRA:MAX:0.5:720:70", # 12 hour max - one month
 724     "RRA:MAX:0.5:10080:70", # 7 day max - ony year
 725 ];
 726
 727 sub cond_create_rrd_file {
 728     my ($filename, $rrddef) = @_;
 729
 730     return if -f $filename;
 731
 732     my @args = ($filename);
 733
 734     push @args, "--daemon" => "unix:${rrdcached_socket}"
 735         if -S $rrdcached_socket;
 736
 737     push @args, '--step', 60;
 738
 739     push @args, @$rrddef;
 740
 741     # print "TEST: " . join(' ', @args) . "\n";
 742
 743     RRDs::create(@args);
 744     my $err = RRDs::error;
 745     die "RRD error: $err\n" if $err;
 746 }
 747
 748 sub update_node_status_rrd {
 749
 750     my $filename = "$rrd_dir/pmg-node-v1.rrd";
 751     cond_create_rrd_file($filename, $rrd_def_node);
 752
 753     my ($avg1, $avg5, $avg15) = PVE::ProcFSTools::read_loadavg();
 754
 755     my $stat = PVE::ProcFSTools::read_proc_stat();
 756
 757     my $netdev = PVE::ProcFSTools::read_proc_net_dev();
 758
 759     my ($uptime) = PVE::ProcFSTools::read_proc_uptime();
 760
 761     my $cpuinfo = PVE::ProcFSTools::read_cpuinfo();
 762
 763     my $maxcpu = $cpuinfo->{cpus};
 764
 765     # traffic from/to physical interface cards
 766     my $netin = 0;
 767     my $netout = 0;
 768     foreach my $dev (keys %$netdev) {
 769         next if $dev !~ m/^eth\d+$/;
 770         $netin += $netdev->{$dev}->{receive};
 771         $netout += $netdev->{$dev}->{transmit};
 772     }
 773
 774     my $meminfo = PVE::ProcFSTools::read_meminfo();
 775
 776     my $dinfo = df('/', 1); # output is bytes
 777
 778     my $ctime = time();
 779
 780     # everything not free is considered to be used
 781     my $dused = $dinfo->{blocks} - $dinfo->{bfree};
 782
 783     my $data = "$ctime:$avg1:$maxcpu:$stat->{cpu}:$stat->{wait}:" .
 784         "$meminfo->{memtotal}:$meminfo->{memused}:" .
 785         "$meminfo->{swaptotal}:$meminfo->{swapused}:" .
 786         "$dinfo->{blocks}:$dused:$netin:$netout";
 787
 788
 789     my @args = ($filename);
 790
 791     push @args, "--daemon" => "unix:${rrdcached_socket}"
 792         if -S $rrdcached_socket;
 793
 794     push @args, $data;
 795
 796     # print "TEST: " . join(' ', @args) . "\n";
 797
 798     RRDs::update(@args);
 799     my $err = RRDs::error;
 800     die "RRD error: $err\n" if $err;
 801 }
 802
 803 sub create_rrd_data {
 804     my ($rrdname, $timeframe, $cf) = @_;
 805
 806     my $rrd = "${rrd_dir}/$rrdname";
 807
 808     my $setup = {
 809         hour =>  [ 60, 70 ],
 810         day  =>  [ 60*30, 70 ],
 811         week =>  [ 60*180, 70 ],
 812         month => [ 60*720, 70 ],
 813         year =>  [ 60*10080, 70 ],
 814     };
 815
 816     my ($reso, $count) = @{$setup->{$timeframe}};
 817     my $ctime  = $reso*int(time()/$reso);
 818     my $req_start = $ctime - $reso*$count;
 819
 820     $cf = "AVERAGE" if !$cf;
 821
 822     my @args = (
 823         "-s" => $req_start,
 824         "-e" => $ctime - 1,
 825         "-r" => $reso,
 826         );
 827
 828     push @args, "--daemon" => "unix:${rrdcached_socket}"
 829         if -S $rrdcached_socket;
 830
 831     my ($start, $step, $names, $data) = RRDs::fetch($rrd, $cf, @args);
 832
 833     my $err = RRDs::error;
 834     die "RRD error: $err\n" if $err;
 835
 836     die "got wrong time resolution ($step != $reso)\n"
 837         if $step != $reso;
 838
 839     my $res = [];
 840     my $fields = scalar(@$names);
 841     for my $line (@$data) {
 842         my $entry = { 'time' => $start };
 843         $start += $step;
 844         for (my $i = 0; $i < $fields; $i++) {
 845             my $name = $names->[$i];
 846             if (defined(my $val = $line->[$i])) {
 847                 $entry->{$name} = $val;
 848             } else {
 849                 # leave empty fields undefined
 850                 # maybe make this configurable?
 851             }
 852         }
 853         push @$res, $entry;
 854     }
 855
 856     return $res;
 857 }
 858
 859 sub decode_to_html {
 860     my ($charset, $data) = @_;
 861
 862     my $res = $data;
 863
 864     eval { $res = encode_entities(decode($charset, $data)); };
 865
 866     return $res;
 867 }
 868
 869 sub decode_rfc1522 {
 870     my ($enc) = @_;
 871
 872     my $res = '';
 873
 874     return '' if !$enc;
 875
 876     eval {
 877         foreach my $r (MIME::Words::decode_mimewords($enc)) {
 878             my ($d, $cs) = @$r;
 879             if ($d) {
 880                 if ($cs) {
 881                     $res .= decode($cs, $d);
 882                 } else {
 883                     $res .= $d;
 884                 }
 885             }
 886         }
 887     };
 888
 889     $res = $enc if $@;
 890
 891     return $res;
 892 }
 893
 894 sub rfc1522_to_html {
 895     my ($enc) = @_;
 896
 897     my $res = '';
 898
 899     return '' if !$enc;
 900
 901     eval {
 902         foreach my $r (MIME::Words::decode_mimewords($enc)) {
 903             my ($d, $cs) = @$r;
 904             if ($d) {
 905                 if ($cs) {
 906                     $res .= encode_entities(decode($cs, $d));
 907                 } else {
 908                     $res .= encode_entities($d);
 909                 }
 910             }
 911         }
 912     };
 913
 914     $res = $enc if $@;
 915
 916     return $res;
 917 }
 918
 919 # RFC 2047 B-ENCODING http://rfc.net/rfc2047.html
 920 # (Q-Encoding is complex and error prone)
 921 sub bencode_header {
 922     my $txt = shift;
 923
 924     my $CRLF = "\015\012";
 925
 926     # Nonprintables (controls + x7F + 8bit):
 927     my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
 928
 929     # always use utf-8 (work with japanese character sets)
 930     $txt = encode("UTF-8", $txt);
 931
 932     return $txt if $txt !~ /[$NONPRINT]/o;
 933
 934     my $res = '';
 935
 936     while ($txt =~ s/^(.{1,42})//sm) {
 937         my $t = MIME::Words::encode_mimeword ($1, 'B', 'UTF-8');
 938         $res .= $res ? "\015\012\t$t" : $t;
 939     }
 940
 941     return $res;
 942 }
 943
 944 sub load_sa_descriptions {
 945
 946     my @dirs = ('/usr/share/spamassassin',
 947                 '/usr/share/spamassassin-extra');
 948
 949     my $res = {};
 950
 951     my $parse_sa_file = sub {
 952         my ($file) = @_;
 953
 954         open(my $fh,'<', $file);
 955         return if !defined($fh);
 956
 957         while (defined(my $line = <$fh>)) {
 958             if ($line =~ m/^describe\s+(\S+)\s+(.*)\s*$/) {
 959                 my ($name, $desc) = ($1, $2);
 960                 next if $res->{$name};
 961                 $res->{$name}->{desc} = $desc;
 962                 if ($desc =~ m|[\(\s](http:\/\/\S+\.[^\s\.\)]+\.[^\s\.\)]+)|i) {
 963                     $res->{$name}->{url} = $1;
 964                 }
 965             }
 966         }
 967         close($fh);
 968     };
 969
 970     foreach my $dir (@dirs) {
 971         foreach my $file (<$dir/*.cf>) {
 972             $parse_sa_file->($file);
 973         }
 974     }
 975
 976     return $res;
 977 }
 978
 979 sub format_uptime {
 980     my ($uptime) = @_;
 981
 982     my $days = int($uptime/86400);
 983     $uptime -= $days*86400;
 984
 985     my $hours = int($uptime/3600);
 986     $uptime -= $hours*3600;
 987
 988     my $mins = $uptime/60;
 989
 990     if ($days) {
 991         my $ds = $days > 1 ? 'days' : 'day';
 992         return sprintf "%d $ds %02d:%02d", $days, $hours, $mins;
 993     } else {
 994         return sprintf "%02d:%02d", $hours, $mins;
 995     }
 996 }
 997
 998 sub finalize_report {
 999     my ($tt, $template, $data, $mailfrom, $receiver, $debug) = @_;
1000
1001     my $html = '';
1002
1003     $tt->process($template, $data, \$html) ||
1004         die $tt->error() . "\n";
1005
1006     my $title;
1007     if ($html =~ m|^\s*<title>(.*)</title>|m) {
1008         $title = $1;
1009     } else {
1010         die "unable to extract template title\n";
1011     }
1012
1013     my $top = MIME::Entity->build(
1014         Type    => "multipart/related",
1015         To      => $data->{pmail},
1016         From    => $mailfrom,
1017         Subject => bencode_header(decode_entities($title)));
1018
1019     $top->attach(
1020         Data     => $html,
1021         Type     => "text/html",
1022         Encoding => $debug ? 'binary' : 'quoted-printable');
1023
1024     if ($debug) {
1025         $top->print();
1026         return;
1027     }
1028     # we use an empty envelope sender (we dont want to receive NDRs)
1029     PMG::Utils::reinject_mail ($top, '', [$receiver], undef, $data->{fqdn});
1030 }
1031
1032 1;