6 # compat for older perl code which allows arbitrary binary data (including invalid UTF-8)
7 # TODO: can we remove this (as our perl source texts should be all UTF-8 compatible)?
29 use POSIX
qw(strftime);
32 use Time
::HiRes qw
(gettimeofday
);
52 my $valid_pmg_realms = ['pam', 'pmg', 'quarantine'];
54 PVE
::JSONSchema
::register_standard_option
('realm', {
55 description
=> "Authentication domain ID",
57 enum
=> $valid_pmg_realms,
61 PVE
::JSONSchema
::register_standard_option
('pmg-starttime', {
62 description
=> "Only consider entries newer than 'starttime' (unix epoch). Default is 'now - 1day'.",
68 PVE
::JSONSchema
::register_standard_option
('pmg-endtime', {
69 description
=> "Only consider entries older than 'endtime' (unix epoch). This is set to '<start> + 1day' by default.",
75 PVE
::JSONSchema
::register_format
('pmg-userid', \
&verify_username
);
77 my ($username, $noerr) = @_;
79 $username = '' if !$username;
80 my $len = length($username);
82 die "user name '$username' is too short\n" if !$noerr;
86 die "user name '$username' is too long ($len > 64)\n" if !$noerr;
90 # we only allow a limited set of characters. Colons aren't allowed, because we store usernames
91 # with colon separated lists! slashes aren't allowed because it is used as pve API delimiter
92 # also see "man useradd"
93 my $realm_list = join('|', @$valid_pmg_realms);
94 if ($username =~ m!^([^\s:/]+)\@(${realm_list})$!) {
95 return wantarray ?
($username, $1, $2) : $username;
98 die "value '$username' does not look like a valid user name\n" if !$noerr;
103 PVE
::JSONSchema
::register_standard_option
('userid', {
104 description
=> "User ID",
105 type
=> 'string', format
=> 'pmg-userid',
110 PVE
::JSONSchema
::register_standard_option
('username', {
111 description
=> "Username (without realm)",
113 pattern
=> '[^\s:\/\@]{1,60}',
117 PVE
::JSONSchema
::register_standard_option
('pmg-email-address', {
118 description
=> "Email Address (allow most characters).",
120 pattern
=> '(?:[^\s\\\@]+\@[^\s\/\\\@]+)',
125 PVE
::JSONSchema
::register_standard_option
('pmg-whiteblacklist-entry-list', {
126 description
=> "White/Blacklist entry list (allow most characters). Can contain globs",
128 pattern
=> '(?:[^\s\/\\\;\,]+)(?:\,[^\s\/\\\;\,]+)*',
133 my ($dbh, $seq) = @_;
135 return $dbh->last_insert_id(
136 undef, undef, undef, undef, { sequence
=> $seq});
139 # quote all regex operators
143 $val =~ s/([\(\)\[\]\/\}\+\*\?\.\|\^\$\\])/\\$1/g;
148 sub file_older_than
{
149 my ($filename, $lasttime) = @_;
151 my $st = stat($filename);
153 return 0 if !defined($st);
155 return ($lasttime >= $st->ctime);
158 sub extract_filename
{
161 if (my $value = $head->recommended_filename()) {
163 if (my $decvalue = MIME
::Words
::decode_mimewords
($value)) {
164 $decvalue =~ s/\0/ /g;
165 $decvalue = PVE
::Tools
::trim
($decvalue);
174 my ($entity, $add_id) = @_;
178 PMG
::MIMEUtils
::traverse_mime_parts
($entity, sub {
180 foreach my $tag (grep {/^x-proxmox-tmp/i} $part->head->tags) {
181 $part->head->delete($tag);
184 $part->head->replace('X-Proxmox-tmp-AID', $id) if $add_id;
189 return $id - 1; # return max AID
193 my ($body, $dh) = @_;
197 foreach my $k (keys %$dh) {
200 $body =~ s/__\Q${k}\E__/$v/gs;
207 sub subst_values_for_header
{
208 my ($header, $dh) = @_;
211 foreach my $line (split('\r?\n\s*', subst_values
($header, $dh))) {
212 $res .= "\n" if $res;
213 $res .= MIME
::Words
::encode_mimewords
(encode
('UTF-8', $line), 'Charset' => 'UTF-8');
216 # support for multiline values (i.e. __SPAM_INFO__)
217 $res =~ s/\n/\n\t/sg; # indent content
218 $res =~ s/\n\s*\n//sg; # remove empty line
219 $res =~ s/\n?\s*$//s; # remove trailing spaces
224 # detects the need for setting smtputf8 based on pmg.conf, addresses and headers
225 sub reinject_local_mail
{
226 my ($entity, $sender, $targets, $xforward, $me) = @_;
228 my $cfg = PMG
::Config-
>new();
231 if ( $cfg->get('mail', 'smtputf8' )) {
232 my $needs_smtputf8 = 0;
234 $needs_smtputf8 = 1 if ($sender =~ /[^\p{PosixPrint}]/);
236 foreach my $target (@$targets) {
237 if ($target =~ /[^\p{PosixPrint}]/) {
243 if (!$needs_smtputf8 && $entity->head()->as_string() =~ /([^\p{PosixPrint}\n\r\t])/) {
247 $params->{mail
}->{smtputf8
} = $needs_smtputf8;
250 return reinject_mail
($entity, $sender, $targets, $xforward, $me, $params);
254 my ($entity, $sender, $targets, $xforward, $me, $params) = @_;
262 my $smtp = Net
::SMTP-
>new('::FFFF:127.0.0.1', Port
=> 10025, Hello
=> $me) ||
263 die "unable to connect to localhost at port 10025";
265 if (defined($xforward)) {
268 foreach my $attr (keys %{$xforward}) {
269 $xfwd .= " $attr=$xforward->{$attr}";
272 if ($xfwd && $smtp->command("XFORWARD", $xfwd)->response() != CMD_OK
) {
273 syslog
('err', "xforward error - got: %s %s", $smtp->code, scalar($smtp->message));
277 my $mail_opts = " BODY=8BITMIME";
278 my $sender_addr = encode
('UTF-8', $smtp->_addr($sender));
279 if (defined($params->{mail
})) {
280 if (delete $params->{mail
}->{smtputf8
}) {
281 $mail_opts .= " SMTPUTF8";
284 my $mailparams = $params->{mail
};
285 for my $p (keys %$mailparams) {
286 $mail_opts .= " $p=$mailparams->{$p}";
290 if (!$smtp->_MAIL("FROM:" . $sender_addr . $mail_opts)) {
291 my @msgs = $smtp->message;
292 $resmess = $msgs[$#msgs];
293 $rescode = $smtp->code;
294 die sprintf("smtp from error - got: %s %s\n", $rescode, $resmess);
297 foreach my $target (@$targets) {
300 if (defined($params->{rcpt
}->{$target})) {
301 my $rcptparams = $params->{rcpt
}->{$target};
302 for my $p (keys %$rcptparams) {
303 $rcpt_opts .= " $p=$rcptparams->{$p}";
306 $rcpt_addr = encode
('UTF-8', $smtp->_addr($target));
308 if (!$smtp->_RCPT("TO:" . $rcpt_addr . $rcpt_opts)) {
309 my @msgs = $smtp->message;
310 $resmess = $msgs[$#msgs];
311 $rescode = $smtp->code;
312 die sprintf("smtp to error - got: %s %s\n", $rescode, $resmess);
317 #$entity->sync_headers ();
320 my $out = PMG
::SMTPPrinter-
>new($smtp);
321 $entity->print($out);
323 # make sure we always have a newline at the end of the mail
324 # else dataend() fails
325 $smtp->datasend("\n");
327 if ($smtp->dataend()) {
328 my @msgs = $smtp->message;
329 $resmess = $msgs[$#msgs];
330 ($resid) = $resmess =~ m/Ok: queued as ([0-9A-Z]+)/;
331 $rescode = $smtp->code;
333 die sprintf("unexpected SMTP result - got: %s %s : WARNING\n", $smtp->code, $resmess);
336 my @msgs = $smtp->message;
337 $resmess = $msgs[$#msgs];
338 $rescode = $smtp->code;
339 die sprintf("sending data failed - got: %s %s : ERROR\n", $smtp->code, $resmess);
344 $smtp->quit if $smtp;
347 syslog
('err', $err);
350 return wantarray ?
($resid, $rescode, $resmess) : $resid;
353 sub analyze_custom_check
{
354 my ($queue, $dname, $pmg_cfg) = @_;
356 my $enable_custom_check = $pmg_cfg->get('admin', 'custom_check');
357 return undef if !$enable_custom_check;
360 my $customcheck_exe = $pmg_cfg->get('admin', 'custom_check_path');
361 my $customcheck_apiver = 'v1';
362 my ($csec, $usec) = gettimeofday
();
372 syslog
('err', $errmsg);
375 my $customcheck_output_apiver;
381 if ($line =~ /^v\d$/) {
382 die "api version already defined!\n" if defined($customcheck_output_apiver);
383 $customcheck_output_apiver = $line;
384 die "api version mismatch - expected $customcheck_apiver, got $customcheck_output_apiver !\n"
385 if ($customcheck_output_apiver ne $customcheck_apiver);
386 } elsif ($line =~ /^SCORE: (-?[0-9]+|.[0-9]+|[0-9]+.[0-9]+)$/) {
389 } elsif ($line =~ /^VIRUS: (.+)$/) {
392 } elsif ($line =~ /^OK$/) {
395 die "got unexpected output!\n";
397 die "got more than 1 result outputs\n" if ( $have_result && $result_flag);
398 $have_result = $result_flag;
401 PVE
::Tools
::run_command
([$customcheck_exe, $customcheck_apiver, $dname],
402 errmsg
=> "$queue->{logid} custom check error",
403 errfunc
=> $log_err, outfunc
=> $parser, timeout
=> $timeout);
405 die "no api version returned\n" if !defined($customcheck_output_apiver);
406 die "no result output!\n" if !$have_result;
411 syslog
('info', "$queue->{logid}: virus detected: $vinfo (custom)");
414 my ($csec_end, $usec_end) = gettimeofday
();
415 $queue->{ptime_custom
} =
416 int (($csec_end-$csec)*1000 + ($usec_end - $usec)/1000);
419 syslog
('err', $err);
421 $queue->{errors
} = 1;
424 $queue->{vinfo_custom
} = $vinfo;
425 $queue->{spam_custom
} = $spam_score;
427 return ($vinfo, $spam_score);
430 sub analyze_virus_clam
{
431 my ($queue, $dname, $pmg_cfg) = @_;
436 my $clamdscan_opts = "--stdout";
438 my ($csec, $usec) = gettimeofday
();
444 $previous_alarm = alarm($timeout);
447 die "$queue->{logid}: Maximum time ($timeout sec) exceeded. " .
448 "virus analyze (clamav) failed: ERROR";
451 open(CMD
, "/usr/bin/clamdscan $clamdscan_opts '$dname'|") ||
452 die "$queue->{logid}: can't exec clamdscan: $! : ERROR";
457 while (defined(my $line = <CMD
>)) {
458 if ($line =~ m/^$dname.*:\s+([^ :]*)\s+FOUND$/) {
459 # we just use the first detected virus name
460 $vinfo = $1 if !$vinfo;
461 } elsif ($line =~ m/^Infected files:\s(\d*)$/i) {
470 alarm(0); # avoid race conditions
472 if (!defined($ifiles)) {
473 die "$queue->{logid}: got undefined output from " .
474 "virus detector: $response : ERROR";
478 syslog
('info', "$queue->{logid}: virus detected: $vinfo (clamav)");
483 alarm($previous_alarm);
485 my ($csec_end, $usec_end) = gettimeofday
();
486 $queue->{ptime_clam
} =
487 int (($csec_end-$csec)*1000 + ($usec_end - $usec)/1000);
490 syslog
('err', $err);
492 $queue->{errors
} = 1;
495 $queue->{vinfo_clam
} = $vinfo;
497 return $vinfo ?
"$vinfo (clamav)" : undef;
500 sub analyze_virus_avast
{
501 my ($queue, $dname, $pmg_cfg) = @_;
506 my ($csec, $usec) = gettimeofday
();
512 $previous_alarm = alarm($timeout);
515 die "$queue->{logid}: Maximum time ($timeout sec) exceeded. " .
516 "virus analyze (avast) failed: ERROR";
519 open(my $cmd, '-|', 'scan', $dname) ||
520 die "$queue->{logid}: can't exec avast scan: $! : ERROR";
523 while (defined(my $line = <$cmd>)) {
524 if ($line =~ m/^$dname\s+(.*\S)\s*$/) {
525 # we just use the first detected virus name
526 $vinfo = $1 if !$vinfo;
534 alarm(0); # avoid race conditions
537 syslog
('info', "$queue->{logid}: virus detected: $vinfo (avast)");
542 alarm($previous_alarm);
544 my ($csec_end, $usec_end) = gettimeofday
();
545 $queue->{ptime_clam
} =
546 int (($csec_end-$csec)*1000 + ($usec_end - $usec)/1000);
549 syslog
('err', $err);
551 $queue->{errors
} = 1;
554 return undef if !$vinfo;
556 $queue->{vinfo_avast
} = $vinfo;
558 return "$vinfo (avast)";
562 my ($queue, $filename, $pmg_cfg, $testmode) = @_;
564 # TODO: support other virus scanners?
567 my $vinfo_clam = analyze_virus_clam
($queue, $filename, $pmg_cfg);
568 my $vinfo_avast = analyze_virus_avast
($queue, $filename, $pmg_cfg);
570 return $vinfo_avast || $vinfo_clam;
573 my $enable_avast = $pmg_cfg->get('admin', 'avast');
576 if (my $vinfo = analyze_virus_avast
($queue, $filename, $pmg_cfg)) {
581 my $enable_clamav = $pmg_cfg->get('admin', 'clamav');
583 if ($enable_clamav) {
584 if (my $vinfo = analyze_virus_clam
($queue, $filename, $pmg_cfg)) {
592 sub magic_mime_type_for_file
{
595 # we do not use get_mime_type_for_file, because that considers
596 # filename extensions - we only want magic type detection
598 my $bufsize = Xdgmime
::xdg_mime_get_max_buffer_extents
();
599 die "got strange value for max_buffer_extents" if $bufsize > 4096*10;
601 my $ct = "application/octet-stream";
603 my $fh = IO
::File-
>new("<$filename") ||
604 die "unable to open file '$filename' - $!";
607 if (($len = $fh->read($buf, $bufsize)) > 0) {
608 $ct = xdg_mime_get_mime_type_for_data
($buf, $len);
612 die "unable to read file '$filename' - $!" if ($len < 0);
620 if (my $path = $entity->{PMX_decoded_path
}) {
622 # set a reasonable default if magic does not give a result
623 $entity->{PMX_magic_ct
} = $entity->head->mime_attr('content-type');
625 if (my $ct = magic_mime_type_for_file
($path)) {
626 if ($ct ne 'application/octet-stream' || !$entity->{PMX_magic_ct
}) {
627 $entity->{PMX_magic_ct
} = $ct;
631 my $filename = $entity->head->recommended_filename;
632 $filename = basename
($path) if !defined($filename) || $filename eq '';
634 if (my $ct = xdg_mime_get_mime_type_from_file_name
($filename)) {
635 $entity->{PMX_glob_ct
} = $ct;
639 foreach my $part ($entity->parts) {
640 add_ct_marks
($part);
644 # x509 certificate utils
646 # only write output if something fails
652 my $record_output = sub {
658 PVE
::Tools
::run_command
($cmd, outfunc
=> $record_output,
659 errfunc
=> $record_output);
664 print STDERR
$outbuf;
669 my $proxmox_tls_cert_fn = "/etc/pmg/pmg-tls.pem";
671 sub gen_proxmox_tls_cert
{
674 my $resolv = PVE
::INotify
::read_file
('resolvconf');
675 my $domain = $resolv->{search
};
677 my $company = $domain; # what else ?
678 my $cn = "*.$domain";
680 return if !$force && -f
$proxmox_tls_cert_fn;
682 my $sslconf = <<__EOD__;
683 RANDFILE = /root/.rnd
688 distinguished_name = req_distinguished_name
689 req_extensions = v3_req
691 string_mask = nombstr
693 [ req_distinguished_name ]
694 organizationalUnitName = Proxmox Mail Gateway
695 organizationName = $company
699 basicConstraints = CA:FALSE
701 keyUsage = nonRepudiation, digitalSignature, keyEncipherment
704 my $cfgfn = "/tmp/pmgtlsconf-$$.tmp";
705 my $fh = IO
::File-
>new ($cfgfn, "w");
710 my $cmd = ['openssl', 'req', '-batch', '-x509', '-new', '-sha256',
711 '-config', $cfgfn, '-days', 3650, '-nodes',
712 '-out', $proxmox_tls_cert_fn,
713 '-keyout', $proxmox_tls_cert_fn];
714 run_silent_cmd
($cmd);
718 unlink $proxmox_tls_cert_fn;
720 die "unable to generate proxmox certificate request:\n$err";
726 sub find_local_network_for_ip
{
727 my ($ip, $noerr) = @_;
729 my $testip = Net
::IP-
>new($ip);
731 my $isv6 = $testip->version == 6;
733 PVE
::ProcFSTools
::read_proc_net_ipv6_route
() :
734 PVE
::ProcFSTools
::read_proc_net_route
();
736 foreach my $entry (@$routes) {
739 $mask = $entry->{prefix
};
740 next if !$mask; # skip the default route...
742 $mask = $PVE::Network
::ipv4_mask_hash_localnet-
>{$entry->{mask
}};
743 next if !defined($mask);
745 my $cidr = "$entry->{dest}/$mask";
746 my $testnet = Net
::IP-
>new($cidr);
747 my $overlap = $testnet->overlaps($testip);
748 if ($overlap == $Net::IP
::IP_B_IN_A_OVERLAP
||
749 $overlap == $Net::IP
::IP_IDENTICAL
)
755 return undef if $noerr;
757 die "unable to detect local network for ip '$ip'\n";
760 my $service_aliases = {
761 'postfix' => 'postfix@-',
764 sub lookup_real_service_name
{
767 if ($alias eq 'postgres') {
768 my $pg_ver = get_pg_server_version
();
769 return "postgresql\@${pg_ver}-main";
772 return $service_aliases->{$alias} // $alias;
775 sub get_full_service_state
{
782 if ($line =~ m/^([^=\s]+)=(.*)$/) {
787 $service = lookup_real_service_name
($service);
788 PVE
::Tools
::run_command
(['systemctl', 'show', $service], outfunc
=> $parser);
793 our $db_service_list = [
794 'pmgpolicy', 'pmgmirror', 'pmgtunnel', 'pmg-smtp-filter' ];
796 sub service_wait_stopped
{
797 my ($timeout, $service_list) = @_;
799 my $starttime = time();
801 foreach my $service (@$service_list) {
802 PVE
::Tools
::run_command
(['systemctl', 'stop', $service]);
808 foreach my $service (@$service_list) {
809 my $ss = get_full_service_state
($service);
810 my $state = $ss->{ActiveState
} // 'unknown';
812 if ($state ne 'inactive') {
813 if ((time() - $starttime) > $timeout) {
814 syslog
('err', "unable to stop services (got timeout)");
829 my ($service, $cmd) = @_;
831 die "unknown service command '$cmd'\n"
832 if $cmd !~ m/^(start|stop|restart|reload|reload-or-restart)$/;
834 if ($service eq 'pmgdaemon' || $service eq 'pmgproxy') {
835 die "invalid service cmd '$service $cmd': refusing to stop essential service!\n"
837 } elsif ($service eq 'fetchmail') {
838 # use restart instead of start - else it does not start 'exited' unit
839 # after setting START_DAEMON=yes in /etc/default/fetchmail
840 $cmd = 'restart' if $cmd eq 'start';
843 $service = lookup_real_service_name
($service);
844 PVE
::Tools
::run_command
(['systemctl', $cmd, $service]);
850 # make sure the file exists (else postmap fails)
851 IO
::File-
>new($filename, 'a', 0644);
853 my $mtime_src = (CORE
::stat($filename))[9] //
854 die "unable to read mtime of $filename\n";
856 my $mtime_dst = (CORE
::stat("$filename.db"))[9] // 0;
858 # if not changed, do nothing
859 return if $mtime_src <= $mtime_dst;
862 PVE
::Tools
::run_command
(
863 ['/usr/sbin/postmap', $filename],
864 errmsg
=> "unable to update postfix table $filename");
875 my $read_cvd_info = sub {
876 my ($dbname, $dbfile) = @_;
879 my $fh = IO
::File-
>new("<$dbfile");
881 warn "can't open ClamAV Database $dbname ($dbfile) - $!\n";
884 $fh->read($header, 512);
887 ## ClamAV-VDB:16 Mar 2016 23-17 +0000:57:4218790:60:06386f34a16ebeea2733ab037f0536be:
888 if ($header =~ m/^(ClamAV-VDB):([^:]+):(\d+):(\d+):/) {
889 my ($ftype, $btime, $version, $nsigs) = ($1, $2, $3, $4);
893 build_time
=> $btime,
898 warn "unable to parse ClamAV Database $dbname ($dbfile)\n";
903 my $filename = "/var/lib/clamav/main.inc/main.info";
904 $filename = "/var/lib/clamav/main.cvd" if ! -f
$filename;
906 $read_cvd_info->('main', $filename) if -f
$filename;
909 $filename = "/var/lib/clamav/daily.inc/daily.info";
910 $filename = "/var/lib/clamav/daily.cvd" if ! -f
$filename;
911 $filename = "/var/lib/clamav/daily.cld" if ! -f
$filename;
913 $read_cvd_info->('daily', $filename) if -f
$filename;
915 $filename = "/var/lib/clamav/bytecode.cvd";
916 $read_cvd_info->('bytecode', $filename) if -f
$filename;
918 my $ss_dbs_fn = "/var/lib/clamav-unofficial-sigs/configs/ss-include-dbs.txt";
919 my $ss_dbs_files = {};
920 if (my $ssfh = IO
::File-
>new("<${ss_dbs_fn}")) {
921 while (defined(my $line = <$ssfh>)) {
923 $ss_dbs_files->{$line} = 1;
928 foreach $filename (</var/lib
/clamav/*>) {
929 my $fn = basename
($filename);
930 next if !$ss_dbs_files->{$fn};
932 my $fh = IO
::File-
>new("<$filename");
933 next if !defined($fh);
936 my $mtime = $st->mtime();
937 $last = $mtime if $mtime > $last;
938 while (defined(my $line = <$fh>)) { $nsigs++; }
943 name
=> 'sanesecurity',
944 type
=> 'unofficial',
945 build_time
=> strftime
("%d %b %Y %H-%M %z", localtime($last)),
954 my $rrd_dir = "/var/lib/rrdcached/db";
955 my $rrdcached_socket = "/var/run/rrdcached.sock";
958 "DS:loadavg:GAUGE:120:0:U",
959 "DS:maxcpu:GAUGE:120:0:U",
960 "DS:cpu:GAUGE:120:0:U",
961 "DS:iowait:GAUGE:120:0:U",
962 "DS:memtotal:GAUGE:120:0:U",
963 "DS:memused:GAUGE:120:0:U",
964 "DS:swaptotal:GAUGE:120:0:U",
965 "DS:swapused:GAUGE:120:0:U",
966 "DS:roottotal:GAUGE:120:0:U",
967 "DS:rootused:GAUGE:120:0:U",
968 "DS:netin:DERIVE:120:0:U",
969 "DS:netout:DERIVE:120:0:U",
971 "RRA:AVERAGE:0.5:1:70", # 1 min avg - one hour
972 "RRA:AVERAGE:0.5:30:70", # 30 min avg - one day
973 "RRA:AVERAGE:0.5:180:70", # 3 hour avg - one week
974 "RRA:AVERAGE:0.5:720:70", # 12 hour avg - one month
975 "RRA:AVERAGE:0.5:10080:70", # 7 day avg - one year
977 "RRA:MAX:0.5:1:70", # 1 min max - one hour
978 "RRA:MAX:0.5:30:70", # 30 min max - one day
979 "RRA:MAX:0.5:180:70", # 3 hour max - one week
980 "RRA:MAX:0.5:720:70", # 12 hour max - one month
981 "RRA:MAX:0.5:10080:70", # 7 day max - one year
984 sub cond_create_rrd_file
{
985 my ($filename, $rrddef) = @_;
987 return if -f
$filename;
989 my @args = ($filename);
991 push @args, "--daemon" => "unix:${rrdcached_socket}"
992 if -S
$rrdcached_socket;
994 push @args, '--step', 60;
996 push @args, @$rrddef;
998 # print "TEST: " . join(' ', @args) . "\n";
1000 RRDs
::create
(@args);
1001 my $err = RRDs
::error
;
1002 die "RRD error: $err\n" if $err;
1005 sub update_node_status_rrd
{
1007 my $filename = "$rrd_dir/pmg-node-v1.rrd";
1008 cond_create_rrd_file
($filename, $rrd_def_node);
1010 my ($avg1, $avg5, $avg15) = PVE
::ProcFSTools
::read_loadavg
();
1012 my $stat = PVE
::ProcFSTools
::read_proc_stat
();
1014 my $netdev = PVE
::ProcFSTools
::read_proc_net_dev
();
1016 my ($uptime) = PVE
::ProcFSTools
::read_proc_uptime
();
1018 my $cpuinfo = PVE
::ProcFSTools
::read_cpuinfo
();
1020 my $maxcpu = $cpuinfo->{cpus
};
1022 # traffic from/to physical interface cards
1025 foreach my $dev (keys %$netdev) {
1026 next if $dev !~ m/^$PVE::Network::PHYSICAL_NIC_RE$/;
1027 $netin += $netdev->{$dev}->{receive
};
1028 $netout += $netdev->{$dev}->{transmit
};
1031 my $meminfo = PVE
::ProcFSTools
::read_meminfo
();
1033 my $dinfo = df
('/', 1); # output is bytes
1037 # everything not free is considered to be used
1038 my $dused = $dinfo->{blocks
} - $dinfo->{bfree
};
1040 my $data = "$ctime:$avg1:$maxcpu:$stat->{cpu}:$stat->{wait}:" .
1041 "$meminfo->{memtotal}:$meminfo->{memused}:" .
1042 "$meminfo->{swaptotal}:$meminfo->{swapused}:" .
1043 "$dinfo->{blocks}:$dused:$netin:$netout";
1046 my @args = ($filename);
1048 push @args, "--daemon" => "unix:${rrdcached_socket}"
1049 if -S
$rrdcached_socket;
1053 # print "TEST: " . join(' ', @args) . "\n";
1055 RRDs
::update
(@args);
1056 my $err = RRDs
::error
;
1057 die "RRD error: $err\n" if $err;
1060 sub create_rrd_data
{
1061 my ($rrdname, $timeframe, $cf) = @_;
1063 my $rrd = "${rrd_dir}/$rrdname";
1067 day
=> [ 60*30, 70 ],
1068 week
=> [ 60*180, 70 ],
1069 month
=> [ 60*720, 70 ],
1070 year
=> [ 60*10080, 70 ],
1073 my ($reso, $count) = @{$setup->{$timeframe}};
1074 my $ctime = $reso*int(time()/$reso);
1075 my $req_start = $ctime - $reso*$count;
1077 $cf = "AVERAGE" if !$cf;
1085 push @args, "--daemon" => "unix:${rrdcached_socket}"
1086 if -S
$rrdcached_socket;
1088 my ($start, $step, $names, $data) = RRDs
::fetch
($rrd, $cf, @args);
1090 my $err = RRDs
::error
;
1091 die "RRD error: $err\n" if $err;
1093 die "got wrong time resolution ($step != $reso)\n"
1097 my $fields = scalar(@$names);
1098 for my $line (@$data) {
1099 my $entry = { 'time' => $start };
1101 for (my $i = 0; $i < $fields; $i++) {
1102 my $name = $names->[$i];
1103 if (defined(my $val = $line->[$i])) {
1104 $entry->{$name} = $val;
1106 # leave empty fields undefined
1107 # maybe make this configurable?
1116 sub decode_to_html
{
1117 my ($charset, $data) = @_;
1121 eval { $res = encode_entities
(decode
($charset, $data)); };
1126 # assume enc contains utf-8 and mime-encoded data returns a perl-string (with wide characters)
1127 sub decode_rfc1522
{
1135 foreach my $r (MIME
::Words
::decode_mimewords
($enc)) {
1139 $res .= decode
($cs, $d);
1141 $res .= try_decode_utf8
($d);
1152 sub rfc1522_to_html
{
1155 my $res = eval { encode_entities
(decode_rfc1522
($enc)) };
1161 # RFC 2047 B-ENCODING http://rfc.net/rfc2047.html
1162 # (Q-Encoding is complex and error prone)
1163 sub bencode_header
{
1166 my $CRLF = "\015\012";
1168 # Nonprintables (controls + x7F + 8bit):
1169 my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
1171 # always use utf-8 (work with japanese character sets)
1172 $txt = encode
("UTF-8", $txt);
1174 return $txt if $txt !~ /[$NONPRINT]/o;
1178 while ($txt =~ s/^(.{1,42})//sm) {
1179 my $t = MIME
::Words
::encode_mimeword
($1, 'B', 'UTF-8');
1180 $res .= $res ?
"\015\012\t$t" : $t;
1186 sub user_bl_description
{
1187 return 'From: address is in the user block-list';
1190 sub load_sa_descriptions
{
1191 my ($additional_dirs) = @_;
1193 my @dirs = ('/usr/share/spamassassin',
1194 '/usr/share/spamassassin-extra');
1196 push @dirs, @$additional_dirs if @$additional_dirs;
1200 my $parse_sa_file = sub {
1203 open(my $fh,'<', $file);
1204 return if !defined($fh);
1206 while (defined(my $line = <$fh>)) {
1207 if ($line =~ m/^(?:\s*)describe\s+(\S+)\s+(.*)\s*$/) {
1208 my ($name, $desc) = ($1, $2);
1209 next if $res->{$name};
1210 $res->{$name}->{desc
} = $desc;
1211 if ($desc =~ m
|[\
(\s
](http
:\
/\/\S
+\
.[^\s\
.\
)]+\
.[^\s\
.\
)]+)|i
) {
1212 $res->{$name}->{url
} = $1;
1219 foreach my $dir (@dirs) {
1220 foreach my $file (<$dir/*.cf
>) {
1221 $parse_sa_file->($file);
1225 $res->{'ClamAVHeuristics'}->{desc
} = "ClamAV heuristic tests";
1226 $res->{'USER_IN_BLACKLIST'}->{desc
} = user_bl_description
();;
1227 $res->{'USER_IN_BLOCKLIST'}->{desc
} = user_bl_description
();;
1235 my $days = int($uptime/86400);
1236 $uptime -= $days*86400;
1238 my $hours = int($uptime/3600);
1239 $uptime -= $hours*3600;
1241 my $mins = $uptime/60;
1244 my $ds = $days > 1 ?
'days' : 'day';
1245 return sprintf "%d $ds %02d:%02d", $days, $hours, $mins;
1247 return sprintf "%02d:%02d", $hours, $mins;
1251 sub finalize_report
{
1252 my ($tt, $template, $data, $mailfrom, $receiver, $debug) = @_;
1256 $tt->process($template, $data, \
$html) ||
1257 die $tt->error() . "\n";
1260 if ($html =~ m
|^\s
*<title
>(.*)</title
>|m
) {
1263 die "unable to extract template title\n";
1266 my $top = MIME
::Entity-
>build(
1267 Type
=> "multipart/related",
1268 To
=> $data->{pmail_raw
},
1270 Subject
=> bencode_header
(decode_entities
($title)));
1274 Type
=> "text/html",
1275 Encoding
=> $debug ?
'binary' : 'quoted-printable');
1281 # we use an empty envelope sender (we don't want to receive NDRs)
1282 PMG
::Utils
::reinject_local_mail
($top, '', [$receiver], undef, $data->{fqdn
});
1285 sub lookup_timespan
{
1286 my ($timespan) = @_;
1288 my (undef, undef, undef, $mday, $mon, $year) = localtime(time());
1289 my $daystart = timelocal
(0, 0, 0, $mday, $mon, $year);
1294 if ($timespan eq 'today') {
1296 $end = $start + 86400;
1297 } elsif ($timespan eq 'yesterday') {
1299 $start = $end - 86400;
1300 } elsif ($timespan eq 'week') {
1302 $start = $end - 7*86400;
1304 die "internal error";
1307 return ($start, $end);
1310 my $rbl_scan_last_cursor;
1311 my $rbl_scan_start_time = time();
1313 sub scan_journal_for_rbl_rejects
{
1315 # example postscreen log entry for RBL rejects
1316 # Aug 29 08:00:36 proxmox postfix/postscreen[11266]: NOQUEUE: reject: RCPT from [x.x.x.x]:1234: 550 5.7.1 Service unavailable; client [x.x.x.x] blocked using zen.spamhaus.org; from=<xxxx>, to=<yyyy>, proto=ESMTP, helo=<zzz>
1318 # example for PREGREET reject
1319 # Dec 7 06:57:11 proxmox postfix/postscreen[32084]: PREGREET 14 after 0.23 from [x.x.x.x]:63492: EHLO yyyyy\r\n
1321 my $identifier = 'postfix/postscreen';
1324 my $pregreet_count = 0;
1327 my $log = decode_json
(shift);
1329 $rbl_scan_last_cursor = $log->{__CURSOR
} if defined($log->{__CURSOR
});
1331 my $message = $log->{MESSAGE
};
1332 return if !defined($message);
1334 if ($message =~ m/^NOQUEUE:\sreject:.*550 5.7.1 Service unavailable/) {
1336 } elsif ($message =~ m/^PREGREET\s\d+\safter\s/) {
1341 # limit to last 5000 lines to avoid long delays
1342 my $cmd = ['journalctl', '-o', 'json', '--output-fields', '__CURSOR,MESSAGE',
1343 '--no-pager', '--identifier', $identifier, '-n', 5000];
1345 if (defined($rbl_scan_last_cursor)) {
1346 push @$cmd, "--after-cursor=${rbl_scan_last_cursor}";
1348 push @$cmd, "--since=@" . $rbl_scan_start_time;
1351 PVE
::Tools
::run_command
($cmd, outfunc
=> $parser);
1353 return ($rbl_count, $pregreet_count);
1357 my $hwaddress_st = {};
1360 my $fn = '/etc/ssh/ssh_host_rsa_key.pub';
1363 if (defined($hwaddress)
1364 && $hwaddress_st->{mtime
} == $st->mtime
1365 && $hwaddress_st->{ino
} == $st->ino
1366 && $hwaddress_st->{dev
} == $st->dev) {
1370 my $sshkey = PVE
::Tools
::file_get_contents
($fn);
1371 $hwaddress = uc(Digest
::MD5
::md5_hex
($sshkey));
1372 $hwaddress_st->@{'mtime', 'ino', 'dev'} = ($st->mtime, $st->ino, $st->dev);
1377 my $default_locale = "en_US.UTF-8 UTF-8";
1379 sub cond_add_default_locale
{
1381 my $filename = "/etc/locale.gen";
1383 open(my $infh, "<", $filename) || return;
1385 while (defined(my $line = <$infh>)) {
1386 if ($line =~ m/^\Q${default_locale}\E/) {
1387 # already configured
1392 seek($infh, 0, 0) // return; # seek failed
1394 open(my $outfh, ">", "$filename.tmp") || return;
1397 while (defined(my $line = <$infh>)) {
1398 if ($line =~ m/^#\s*\Q${default_locale}\E.*/) {
1399 print $outfh "${default_locale}\n" if !$done;
1406 print STDERR
"generation pmg default locale\n";
1408 rename("$filename.tmp", $filename) || return; # rename failed
1410 system("dpkg-reconfigure locales -f noninteractive");
1413 sub postgres_admin_cmd
{
1414 my ($cmd, $options, @params) = @_;
1416 $cmd = ref($cmd) ?
$cmd : [ $cmd ];
1418 my $save_uid = POSIX
::getuid
();
1419 my $pg_uid = getpwnam('postgres') || die "getpwnam postgres failed\n";
1421 # cd to / to prevent warnings on EPERM (e.g. when running in /root)
1422 my $cwd = getcwd
() || die "getcwd failed - $!\n";
1423 ($cwd) = ($cwd =~ m
|^(/.*)$|); #untaint
1424 chdir('/') || die "could not chdir to '/' - $!\n";
1425 PVE
::Tools
::setresuid
(-1, $pg_uid, -1) ||
1426 die "setresuid postgres ($pg_uid) failed - $!\n";
1428 PVE
::Tools
::run_command
([@$cmd, '-U', 'postgres', @params], %$options);
1430 PVE
::Tools
::setresuid
(-1, $save_uid, -1) ||
1431 die "setresuid back failed - $!\n";
1433 chdir("$cwd") || die "could not chdir back to old working dir ($cwd) - $!\n";
1436 sub get_pg_server_version
{
1442 # 11.4 (Debian 11.4-1)
1443 # see https://www.postgresql.org/support/versioning/
1444 my ($first_comp) = ($line =~ m/^\s*([0-9]+)/);
1445 if ($first_comp < 10) {
1446 ($major_ver) = ($line =~ m/^([0-9]+\.[0-9]+)\.[0-9]+/);
1448 $major_ver = $first_comp;
1453 postgres_admin_cmd
('psql', { outfunc
=> $parser }, '--quiet',
1454 '--tuples-only', '--no-align', '--command', 'show server_version;');
1457 die "Unable to determine currently running Postgresql server version\n"
1458 if ($@ || !defined($major_ver));
1463 sub reload_smtp_filter
{
1465 my $pid_file = '/run/pmg-smtp-filter.pid';
1466 my $pid = PVE
::Tools
::file_read_firstline
($pid_file);
1470 return 0 if $pid !~ m/^(\d+)$/;
1471 $pid = $1; # untaint
1473 return kill (10, $pid); # send SIGUSR1
1480 foreach my $d (@$domains) {
1481 # skip domains with non-DNS name characters
1482 next if $d =~ m/[^A-Za-z0-9\-\.]/;
1483 if ($d =~ m/^\.(.*)$/) {
1485 $dom =~ s/\./\\\./g;
1487 push @ra, "\.\*\\.$dom";
1494 my $re = join ('|', @ra);
1496 my $regex = qr/\@($re)$/i;
1501 sub read_sa_channel
{
1502 my ($filename) = @_;
1504 my $content = PVE
::Tools
::file_get_contents
($filename);
1506 filename
=> $filename,
1509 ($channel->{keyid
}) = ($content =~ /^KEYID=([a-fA-F0-9]+)$/m);
1510 die "no KEYID in $filename!\n" if !defined($channel->{keyid
});
1511 ($channel->{channelurl
}) = ($content =~ /^CHANNELURL=(.+)$/m);
1512 die "no CHANNELURL in $filename!\n" if !defined($channel->{channelurl
});
1513 ($channel->{gpgkey
}) = ($content =~ /(?:^|\n)(-----BEGIN PGP PUBLIC KEY BLOCK-----.+-----END PGP PUBLIC KEY BLOCK-----)(?:\n|$)/s);
1514 die "no GPG public key in $filename!\n" if !defined($channel->{gpgkey
});
1519 sub local_spamassassin_channels
{
1523 my $local_channel_dir = '/etc/mail/spamassassin/channel.d/';
1525 PVE
::Tools
::dir_glob_foreach
($local_channel_dir, '.*\.conf', sub {
1526 my ($filename) = @_;
1527 my $channel = read_sa_channel
($local_channel_dir.$filename);
1528 push(@$res, $channel);
1534 sub update_local_spamassassin_channels
{
1536 # import all configured channel's gpg-keys to sa-update's keyring
1537 my $localchannels = PMG
::Utils
::local_spamassassin_channels
();
1538 for my $channel (@$localchannels) {
1539 my $importcmd = ['sa-update', '--import', $channel->{filename
}];
1540 push @$importcmd, '-v' if $verbose;
1542 print "Importing gpg key from $channel->{filename}\n" if $verbose;
1543 PVE
::Tools
::run_command
($importcmd);
1546 my $fresh_updates = 0;
1548 for my $channel (@$localchannels) {
1549 my $cmd = ['sa-update', '--channel', $channel->{channelurl
}, '--gpgkey', $channel->{keyid
}];
1550 push @$cmd, '-v' if $verbose;
1552 print "Updating $channel->{channelurl}\n" if $verbose;
1553 my $ret = PVE
::Tools
::run_command
($cmd, noerr
=> 1);
1554 die "updating $channel->{channelurl} failed - sa-update exited with $ret\n" if $ret >= 2;
1556 $fresh_updates = 1 if $ret == 0;
1559 return $fresh_updates
1562 sub get_existing_object_id
{
1563 my ($dbh, $obj_id, $obj_type, $value) = @_;
1565 my $sth = $dbh->prepare("SELECT id FROM Object WHERE ".
1566 "Objectgroup_ID = ? AND ".
1567 "ObjectType = ? AND ".
1570 $sth->execute($obj_id, $obj_type, $value);
1572 if (my $ref = $sth->fetchrow_hashref()) {
1579 sub try_decode_utf8
{
1581 return eval { decode
('UTF-8', $data, 1) } // $data;
1587 # some errors in regex only create warnings e.g. m/^*foo/ others actually cause a
1588 # die e.g. m/*foo/ - treat a warn die here
1589 local $SIG{__WARN__
} = sub { die @_ };
1590 eval { "" =~ m/$regex/i; };
1591 die "invalid regex: $@\n" if $@;