replace /var/run with /run

[pmg-api.git] / src / bin / pmgpolicy

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;
use POSIX qw(errno_h signal_h);

use Net::Server::PreForkSimple;
use Net::DNS::Resolver;
use Mail::SPF;
use Fcntl;
use Fcntl ':flock';
use IO::Multiplex;
use Time::HiRes qw(gettimeofday);
use Time::Zone;

use PVE::INotify;
use PVE::Tools;
use PVE::SafeSyslog;

use PMG::Utils;
use PMG::RuleDB;
use PMG::DBTools;
use PMG::RuleCache;
use PMG::Config;
use PMG::ClusterConfig;

use base qw(Net::Server::PreForkSimple);

my $greylist_delay = 3*60;            # greylist window
my $greylist_lifetime = 3600*24*2;    # retry window
my $greylist_awlifetime = 3600*24*36; # expire window

my $opt_commandline = [$0, @ARGV];

my $opt_max_dequeue = 1;
my $opt_dequeue_time = 60*2;

my $opt_testmode;
my $opt_pidfile;
my $opt_database;
my $opt_policy_port = 10022;

my %_opts = (
    'pidfile=s' => \$opt_pidfile,
    'testmode' => \$opt_testmode,
    'database=s' => \$opt_database,
    'port=i' => \$opt_policy_port,
);
if (!GetOptions(%_opts)) {
    die "usage error\n";
    exit (-1);
}

$opt_pidfile = "/run/pmgpolicy.pid" if !$opt_pidfile;
$opt_max_dequeue = 0 if $opt_testmode;

initlog('pmgpolicy', 'mail');

my $max_servers = 5;

if (!$opt_testmode) {

    my $pmg_cfg = PMG::Config->new ();
    my $demo = $pmg_cfg->get('admin', 'demo');
    $max_servers = $pmg_cfg->get('mail', 'max_policy');

    if ($demo) {
	syslog('info', 'demo mode detected - not starting server');
	exit(0);
    }
}

my $daemonize = 1;
if (defined ($ENV{BOUND_SOCKETS})) {
    $daemonize = undef;
}


my $server_attr = {
    port => [ $opt_policy_port ],
    host => '127.0.0.1',
    max_servers => $max_servers,
    max_dequeue => $opt_max_dequeue,
    check_for_dequeue => $opt_dequeue_time,
    log_level => 3,
    pid_file => $opt_pidfile,
    commandline => $opt_commandline,
    no_close_by_child => 1,
    setsid => $daemonize,
};

my $database;
if (defined($opt_database)) {
    $database = $opt_database;
} else {
    $database = "Proxmox_ruledb";
}

$SIG{'__WARN__'} = sub {
    my $err = $@;
    my $t = $_[0];
    chomp $t;
    syslog('warning', "WARNING: %s", $t);
    $@ = $err;
};

sub update_rbl_stats {
    my ($dbh, $lcid) = @_;

    my ($rbl_count, $pregreet_count) = PMG::Utils::scan_journal_for_rbl_rejects();
    return if !$rbl_count && !$pregreet_count;

    my $timezone = tz_local_offset();;
    my $hour = int((time() + $timezone)/3600) * 3600;

    my $sth = $dbh->prepare(
	'INSERT INTO LocalStat (Time, RBLCount, PregreetCount, CID, MTime) ' .
	'VALUES (?, ?, ?, ?, EXTRACT(EPOCH FROM now())) ' .
	'ON CONFLICT (Time, CID) DO UPDATE SET ' .
	'RBLCount = LocalStat.RBLCount + excluded.RBLCount, ' .
	'PregreetCount = LocalStat.PregreetCount + excluded.PregreetCount, ' .
	'MTime = excluded.MTime');

    $sth->execute($hour, $rbl_count, $pregreet_count, $lcid);
    $sth->finish();
};

sub run_dequeue {
    my $self = shift;

    $self->log(2, "starting policy database maintainance (greylist, rbl)");

    my $cinfo = PMG::ClusterConfig->new();
    my $lcid = $cinfo->{local}->{cid};
    my $role = $cinfo->{local}->{type} // '-';

    my $dbh;

    eval {
	$dbh = PMG::DBTools::open_ruledb($database);
    };
    my $err = $@;

    if ($err) {
	$self->log(0, "ERROR: $err");
	return;
    }

    my ($csec, $usec) = gettimeofday ();

    eval { update_rbl_stats($dbh, $lcid); };
    $err = $@;

    my ($csec_end, $usec_end) = gettimeofday ();
    my $rbltime = int (($csec_end-$csec)*1000 + ($usec_end - $usec)/1000);
    ($csec, $usec) = ($csec_end, $usec_end);

    if ($err) {
	$self->log(0, "rbl update error: $err");
	# continue;
    }

    my $now = time();

    my $ecount = 0;

    eval {

	$dbh->begin_work;

	# we do not lock the table here to avoid delays
	# but that is OK, because we only touch expired records
	# which do not change nornmally
	## $dbh->do ("LOCK TABLE CGreylist IN ROW EXCLUSIVE MODE");

	# move expired and undelivered records from Greylist to Statistic

	my $rntxt = '';
	if (!$lcid) {
	    $rntxt = "AND CID = 0";
	} else {
	    if ($role eq 'master') {
		# master is responsible for all non-cluster (deleted) nodes
		foreach my $rcid (@{$cinfo->{remnodes}}) {
		    $rntxt .= $rntxt ? " AND CID != $rcid" : "AND (CID != $rcid";
		}
		$rntxt .= ")" if $rntxt;
	    } else {
		$rntxt = "AND (CID = 0 OR CID = $lcid)";
	    }
	}


	my $cmds = '';

	my $sth = $dbh->prepare(
	    "SELECT distinct instance, sender FROM CGreylist " .
	    "WHERE passed = 0 AND extime < ? $rntxt");

	$sth->execute ($now);


	while (my $ref = $sth->fetchrow_hashref()) {
	    my $sth2 = $dbh->prepare(
		"SELECT * FROM CGreylist WHERE instance = ? AND sender = ?");
	    $sth2->execute ($ref->{instance}, $ref->{sender});
	    my $rctime;
	    my @rcvrs;
	    my $bc = 0;

	    while (my $ref2 = $sth2->fetchrow_hashref()) {
		$rctime = $ref2->{rctime} if !$rctime;
		$bc += $ref2->{blocked};
		push  @rcvrs, $ref2->{receiver};
	    }

	    $sth2->finish();

	    # hack: sometimes query sth2 does not return anything - maybe a
	    # postgres bug? We simply ignore (when rctime is undefined) it
	    # to avoid problems.

	    if ($rctime) {
		$cmds .=  "SELECT nextval ('cstatistic_id_seq');" .
		    "INSERT INTO CStatistic " .
		    "(CID, RID, ID, Time, Bytes, Direction, Spamlevel, VirusInfo, PTime, Sender) VALUES (" .
		    "$lcid, currval ('cstatistic_id_seq'), currval ('cstatistic_id_seq'), ";

		my $sl = $bc >= 100000 ? 4 : 5;
		$cmds .= $rctime . ", 0, '1', $sl, NULL, 0, ";
		$cmds .= $dbh->quote ($ref->{sender}) . ');';

		foreach my $r (@rcvrs) {
		    my $tmp = $dbh->quote ($r);
		    $cmds .= "INSERT INTO CReceivers (CStatistic_CID, CStatistic_RID, Receiver, Blocked) ".
			"VALUES ($lcid, currval ('cstatistic_id_seq'), $tmp, '1'); ";
		}
	    }

	    if (length ($cmds) > 100000) {
		$dbh->do ($cmds);
		$cmds = '';
	    }

	    $ecount++;

	    # this produces too much log traffic
	    # my $targets = join (", ", @rcvrs);
	    #my $msg = "expire mail $ref->{instance} from $ref->{sender} to $targets";
	    #$self->log (0, $msg);
	}

	$dbh->do ($cmds) if $cmds;

	$sth->finish();

	if ($ecount > 0) {
	    my $msg = "found $ecount expired mails in greylisting database";
	    $self->log (0, $msg);
	}

	$dbh->do ("DELETE FROM CGreylist WHERE extime < $now");

	$dbh->commit;
    };
    $err = $@;

    ($csec_end, $usec_end) = gettimeofday ();
    my $ptime = int (($csec_end-$csec)*1000 + ($usec_end - $usec)/1000);

    if ($err) {
	$dbh->rollback if $dbh;
	$self->log(0, "greylist database update error: $err");
    }

    $self->log(2, "end policy database maintainance ($rbltime ms, $ptime ms)");

    $dbh->disconnect() if $dbh;
}

sub pre_loop_hook {
    my $self = shift;

    my $prop = $self->{server};

    $prop->{log_level} = 3;

    $self->log(0, "Policy daemon (re)started");

    $SIG{'USR1'} = sub {
	# reloading server configuration
	if (defined $prop->{children}) {
	    foreach my $pid (keys %{$prop->{children}}) {
		kill(10, $pid); # SIGUSR1 childs
	    }
	}
    };

    my $sig_set = POSIX::SigSet->new;
    $sig_set->addset (&POSIX::SIGHUP);
    $sig_set->addset (&POSIX::SIGCHLD);
    my $old_sig_set = POSIX::SigSet->new();

    sigprocmask (SIG_UNBLOCK, $sig_set, $old_sig_set);
}

sub load_config {
    my $self = shift;

    my $prop = $self->{server};

    if ($self->{ruledb}) {
	$self->log(0, "reloading configuration $database");
	$self->{ruledb}->close();
    }

    my $pmg_cfg = PMG::Config->new ();
    $self->{use_spf} = $pmg_cfg->get('mail', 'spf');
    $self->{use_greylist} = $pmg_cfg->get('mail', 'greylist');

    if ($opt_testmode) {
	$self->{use_spf} = 1;
	$self->{use_greylist} = 1;
    }

    my $nodename = PVE::INotify::nodename();
    $self->{fqdn} = PVE::Tools::get_fqdn($nodename);

    my $cinfo = PMG::ClusterConfig->new();
    my $lcid = $cinfo->{local}->{cid};
    $self->{cinfo} = $cinfo;
    $self->{lcid} = $lcid;

    my $dbh;

    eval {
	$dbh = PMG::DBTools::open_ruledb($database);
	$self->{ruledb} = PMG::RuleDB->new($dbh);
	$self->{rulecache} = PMG::RuleCache->new($self->{ruledb});
    };
    if (my $err = $@) {
	$self->log(0, "ERROR: unable to load database : $err");
    }

    $self->{reload_config} = 0;
}

sub child_init_hook {
    my $self = shift;

    my $prop = $self->{server};

    $0 = 'pmgpolicy child';

    setup_fork_signal_mask(0); # unblocking signals for children

    eval {
	$self->load_config();

	$self->{mux} = IO::Multiplex->new();
	$self->{mux}->set_callback_object($self);

	my %dnsargs = (
	    tcp_timeout => 3,
	    udp_timeout => 3,
	    retry => 1,
	    retrans => 0,
	    dnsrch => 0,
	    defnames => 0,
	    );

	if ($opt_testmode) {
	    # $dnsargs{nameservers} = [ qw (213.129.232.1 213.129.226.2) ];
	}

	$self->{dns_resolver} = Net::DNS::Resolver->new(%dnsargs);

	$self->{spf_server} = Mail::SPF::Server->new(
	    hostname => $self->{fqdn}, dns_resolver => $self->{dns_resolver});
    };
    if (my $err = $@) {
	$self->log(0, $err);
	$self->child_finish_hook;
	exit(-1);
    }

    $SIG{'USR1'} = sub {
	$self->{reload_config} = 1;
    }
}

sub child_finish_hook {
    my $self = shift;

    my $prop = $self->{server};

    $self->{ruledb}->close() if $self->{ruledb};
}

sub get_spf_result {
    my ($self, $instance, $ip, $helo, $sender) = @_;

    my $result;
    my $spf_header;
    my $local_expl;
    my $auth_expl;

    # we only use helo tests when we have no sender,
    # helo is sometimes empty, so we cant use SPF helo tests
    # in that case - strange
    if ($helo && !$sender) {
	my $query;

	if (defined ($self->{cache}->{$instance}) &&
	    defined ($self->{cache}->{$instance}->{spf_helo_result})) {

	    $query = $self->{cache}->{$instance}->{spf_helo_result};

	} else {
	    my $request = Mail::SPF::Request->new(
		scope => 'helo', identity => $helo, ip_address => $ip);

	    $query = $self->{cache}->{$instance}->{spf_helo_result} =
		$self->{spf_server}->process ($request);
	}

	$result = $query->code;
	$spf_header = $query->received_spf_header;
	$local_expl = $query->local_explanation;
	$auth_expl = $query->authority_explanation if $query->is_code('fail');

	# return if we get a definitive result
	if ($result eq 'pass' || $result eq 'fail' || $result eq 'temperror') {
	    return ($result, $spf_header, $local_expl, $auth_expl);
	}
    }

    if ($sender) {

	my $query;

	if (defined ($self->{cache}->{$instance}) &&
	    defined ($self->{cache}->{$instance}->{spf_mfrom_result})) {

	    $query = $self->{cache}->{$instance}->{spf_mfrom_result};

	} else {

	    my $request = Mail::SPF::Request->new(
		scope => 'mfrom', identity => $sender,
		ip_address => $ip, helo_identity => $helo);

	    $query = $self->{cache}->{$instance}->{spf_mfrom_result} =
		$self->{spf_server}->process($request);
	}

	$result = $query->code;
	$spf_header = $query->received_spf_header;
	$local_expl = $query->local_explanation;
	$auth_expl = $query->authority_explanation if $query->is_code('fail');

	return ($result, $spf_header, $local_expl, $auth_expl);
    }

    return undef;
}

sub is_backup_mx {
    my ($self, $ip, $receiver) = @_;

    my ($rdomain) = $receiver =~ /([^@]+)$/;

    my $dkey = "BKMX:$rdomain";

    if (defined ($self->{cache}->{$dkey}) &&
	($self->{cache}->{$dkey}->{status} == 1)) {
	return $self->{cache}->{$dkey}->{$ip};
    }

    my $resolver = $self->{dns_resolver};

    if (my $mx = $resolver->send($rdomain, 'MX')) {
	$self->{cache}->{$dkey}->{status} = 1;
	my @mxa = grep { $_->type eq 'MX' } $mx->answer;
	my @mxl = sort { $a->preference <=> $b->preference } @mxa;
	# shift @mxl; # optionaly skip primary MX ?
	foreach my $rr (@mxl) {
	    my $a = $resolver->send ($rr->exchange, 'A');
	    if ($a) {
		foreach my $rra ($a->answer) {
		    if ($rra->type eq 'A') {
			$self->{cache}->{$dkey}->{$rra->address} = 1;
		    }
		}
	    }
	}
    } else {
	$self->{cache}->{$dkey}->{status} = 0;
    }

    return $self->{cache}->{$dkey}->{$ip};
}

sub greylist_value {
    my ($self, $ctime, $helo, $ip, $sender, $rcpt, $instance) = @_;

    my $rulecache = $self->{rulecache};

    my $dbh = $self->{ruledb}->{dbh};

    # try to reconnect if database connection is broken
    if (!$dbh->ping) {
	$self->log(0, 'Database connection broken - trying to reconnect');
	my $dbh;
	eval {
	    $dbh = PMG::DBTools::open_ruledb($database);
	};
	my $err = $@;
	if ($err) {
	    $self->log(0, "unable to reconnect to database server: $err");
	    return 'dunno';
	}
	$self->{ruledb} = PMG::RuleDB->new($dbh);
    }

    # some sender substitutions
    my ($user, $domain) = split('@', $sender, 2);
    if (defined ($user) && defined ($domain)) {
	# see http://cr.yp.to/proto/verp.txt
	$user =~ s/\+.*//; # strip extensions  (mailing-list VERP)
	$user =~ s/\b\d+\b/#/g; #replace nubmers in VERP address
	$sender = "$user\@$domain";
    }

    if ($self->is_backup_mx($ip, $rcpt)) {
	$self->log(3, "accept mails from backup MX host - $ip");
	return 'dunno';
    }

    # greylist exclusion (sender whitelist)
    if ($rulecache->greylist_match ($sender, $ip)) {
	$self->log(3, "accept mails from whitelist - $ip");
	return 'dunno';
    }

    # greylist exclusion (receiver whitelist)
    if ($rulecache->greylist_match_receiver ($rcpt)) {
	$self->log(3, "accept mails to whitelist - <$rcpt>");
	return 'dunno';
    }

    my ($net, $host) = $ip =~ m/(\d+\.\d+\.\d+)\.(\d+)/; # IPv4 for now
    return 'dunno' if !defined($net);

    my $spf_header;

    if ((!$opt_testmode && $self->{use_spf}) ||
	($opt_testmode && ($rcpt =~ m/^testspf/))) {

	# ask SPF
 	my $spf_result;
	my $local_expl,
	my $auth_expl;

	my $previous_alarm;

	my ($result, $smtp_comment, $header_comment);

	eval {
	    $previous_alarm = alarm(10);
	    local $SIG{ALRM} = sub { die "SPF timeout\n" };

	    ($result, $spf_header, $local_expl, $auth_expl) =
		$self->get_spf_result($instance, $ip, $helo, $sender);

	    alarm(0); # avoid race condition
	};
	my $err = $@;

	alarm($previous_alarm) if defined($previous_alarm);

	if ($err) {
            $err = $err->text if UNIVERSAL::isa ($err, 'Mail::SPF::Exception');
	    $self->log (0, $err);
	} else {

	    if ($result && $result eq 'pass') {
		$self->log(3, "SPF says $result");
		$spf_result = $spf_header ? "prepend $spf_header" : 'dunno';
	    }

	    if ($result && $result eq 'fail') {
		$self->log(3, "SPF says $result");
		$spf_result = "reject ${auth_expl}";

		eval {

		    $dbh->begin_work;

		    # try to avoid locks everywhere - we use merge instead of insert
		    #$dbh->do ("LOCK TABLE CGreylist IN ROW EXCLUSIVE MODE");

		    # check if there is already a record in the GL database
		    my $sth = $dbh->prepare(
			"SELECT * FROM CGreylist " .
			"where IPNet = ? AND Sender = ? AND Receiver = ?");

		    $sth->execute($net, $sender, $rcpt);
		    my $ref = $sth->fetchrow_hashref();
		    $sth->finish();

		    # else add an entry to the GL Database with short
		    # expiration time. run_dequeue() moves those entries into the statistic
		    # table later. We set 'blocked' to 100000 to identify those entries.

		    if (!defined($ref->{rctime})) {

			$dbh->do($PMG::DBTools::cgreylist_merge_sql, undef,
				 $net, $host, $sender, $rcpt, $instance,
				 $ctime, $ctime + 10, 0, 100000, 0, $ctime, $self->{lcid});
		    }

		    $dbh->commit;
		};
		if (my $err = $@) {
		    $dbh->rollback;
		    $self->log(0, $err);
		}
	    }
	}

	return $spf_result if $spf_result;
    }


    my $res = 'dunno';

    # add spf_header once - SA can re-use this information
    if (!defined($self->{cache}->{$instance}) ||
	!$self->{cache}->{$instance}->{spf_header_added}) {
	$res = "prepend $spf_header" if $spf_header;
	$self->{cache}->{$instance}->{spf_header_added} = 1;
    }

    return $res if !$self->{use_greylist};

    my $defer_res = "defer_if_permit Service is unavailable (try later)";

    eval {

	# we dont use alarm here, because it does not work with DBI

	$dbh->begin_work;

	# try to avoid locks everywhere - we use merge instead of insert
	#$dbh->do ("LOCK TABLE CGreylist IN ROW EXCLUSIVE MODE");

	my $sth = $dbh->prepare(
	    "SELECT * FROM CGreylist " .
	    "where IPNet = ? AND Sender = ? AND Receiver = ?");

	$sth->execute($net, $sender, $rcpt);

	my $ref = $sth->fetchrow_hashref();

	$sth->finish();

	if (!defined($ref->{rctime})) {

	    $dbh->do($PMG::DBTools::cgreylist_merge_sql, undef,
		     $net, $host, $sender, $rcpt, $instance,
		     $ctime, $ctime + $greylist_lifetime, 0, 1, 0, $ctime, $self->{lcid});

	    $res = $defer_res;
	    $self->log(3, "defer greylisted mail");
	} else {
	    my $age = $ctime - $ref->{rctime};

	    if ($age < $greylist_delay) {
		# defer (resent within greylist_delay window)
		$res = $defer_res;
		$self->log(3, "defer greylisted mail");
		$dbh->do("UPDATE CGreylist " .
			 "SET  Blocked = Blocked + 1, Host = ?, MTime = ? " .
			 "WHERE IPNet = ? AND Sender = ? AND Receiver = ?", undef,
			 $host, $ctime, $net, $sender, $rcpt);
	    } else {
		if ($ctime < $ref->{extime}) {
		    # accept (not expired)
		    my $lifetime = $sender eq "" ? 0 : $greylist_awlifetime;
		    my $delay = $ref->{passed} ? "" : "Delay = $age, ";
		    $dbh->do("UPDATE CGreylist " .
			     "SET  Passed =  Passed + 1, $delay Host = ?, ExTime = ?, MTime = ? " .
			     "WHERE IPNet =  ? AND Sender = ? AND Receiver = ?", undef,
			     $host, $ctime + $lifetime, $ctime, $net, $sender, $rcpt);
		} else {
		    # defer (record is expired)
		    $res = $defer_res;
		    $dbh->do("UPDATE CGreylist " .
			     "SET  Host = ?, RCTime = ?, ExTime = ?, MTime = ?, Instance = ?, " .
			     "Blocked = 1, Passed = 0 " .
			     "WHERE IPNet =  ? AND Sender = ? AND Receiver = ?", undef,
			     $host, $ctime, $ctime + $greylist_lifetime, $ctime, $instance,
			     $net, $sender, $rcpt);
		}
	    }
	}

        $dbh->commit;
    };
    if (my $err = $@) {
	$dbh->rollback;
	$self->log (0, $err);
    }

    return $res;
}

# shutdown connections: we need this - else file handles are
# not closed and we run out of handles
sub mux_eof {
    my ($self, $mux, $fh) = @_;

    $mux->shutdown($fh, 1);
}


my $last_reload_test = 0;
my $last_confid_version;
my (undef, $pmgconffilename) = PVE::INotify::ccache_info('pmg.conf');
sub test_config_version {

    my $ctime = time();

    if (($ctime - $last_reload_test) < 5) { return 0; }

    $last_reload_test = $ctime;

    my $version = PVE::INotify::poll_changes($pmgconffilename);

    if (!defined($last_confid_version) ||
	$last_confid_version != $version) {
	$last_confid_version = $version;
	return 1;
    }

    return 0;
}

sub mux_input {
    my ($self, $mux, $fh, $dataref) = @_;
    my $prop = $self->{server};

    my $attribute = {};

    eval {
	$self->{reload_config} = 1 if test_config_version();
	$self->load_config() if $self->{reload_config};

	while ($$dataref =~ s/^([^\r\n]*)\r?\n//) {
	    my $line = $1;
	    next if !defined ($line);

	    if ($line =~ m/([^=]+)=(.*)/) {
		$attribute->{substr($1, 0, 255)} = substr($2, 0, 255);
	    } elsif ($line eq '') {
		my $res = 'dunno';
		my $ctime = time;

		if ($opt_testmode) {
		    die "undefined test time :ERROR" if !defined $attribute->{testtime};
		    $ctime = $attribute->{testtime};
		}

		if ($attribute->{instance} && $attribute->{recipient} &&
		    $attribute->{client_address} && $attribute->{request} &&
		    $attribute->{request} eq 'smtpd_access_policy') {

		    eval {

			$res = $self->greylist_value(
			    $ctime,
			    lc ($attribute->{helo_name}),
			    lc ($attribute->{client_address}),
			    lc ($attribute->{sender}),
			    lc ($attribute->{recipient}),
			    lc ($attribute->{instance}));
		    };
		    if (my $err = $@) {
			$self->log(0, $err);
		    }
		}

		print $fh "action=$res\n\n";

		$attribute = {};
	    } else {
		$self->log(0, "greylist policy protocol error - got '%s'", $line);
	    }
	}
    };
    my $err = $@;

    # remove remaining data, if any
    if ($$dataref ne '') {
	$self->log(0, "greylist policy protocol error - unused data '%s'", $$dataref);
	$$dataref = '';
    }

    $self->log(0, $err) if $err;
}

sub restart_close_hook {
    my $self = shift;

    my $sig_set = POSIX::SigSet->new;
    $sig_set->addset(&POSIX::SIGHUP);
    $sig_set->addset(&POSIX::SIGCHLD); # to avoid zombies
    my $old_sig_set = POSIX::SigSet->new();

    sigprocmask(SIG_BLOCK, $sig_set, $old_sig_set);
}

sub pre_server_close_hook {
    my $self = shift;

    my $prop = $self->{server};

    if (defined $prop->{_HUP}) {
	undef $prop->{pid_file_unlink};
    }

    if (defined $prop->{children}) {
	foreach my $pid (keys %{$prop->{children}}) {
	    kill(1, $pid); # HUP childs
	}
    }

    # nicely shutdown childs (give them max 30 seconds to shut down)
    my $previous_alarm = alarm(30);
    eval {
	local $SIG{ALRM} = sub { die "Timed Out!\n" };

	my $pid;
	1 while ((($pid = waitpid(-1, 0)) > 0) || ($! == EINTR));

	alarm(0); # avoid race
    };
    alarm ($previous_alarm);
}

sub setup_fork_signal_mask {
    my $block = shift;

    my $sig_set = POSIX::SigSet->new;
    $sig_set->addset(&POSIX::SIGINT);
    $sig_set->addset(&POSIX::SIGTERM);
    $sig_set->addset(&POSIX::SIGQUIT);
    $sig_set->addset(&POSIX::SIGHUP);
    my $old_sig_set = POSIX::SigSet->new();

    if ($block) {
	sigprocmask (SIG_BLOCK, $sig_set, $old_sig_set);
    } else {
	sigprocmask (SIG_UNBLOCK, $sig_set, $old_sig_set);
    }
}

# subroutine to start up a specified number of children.
# We need to block signals until handlers are set up correctly.
# Else its possible that HUP occurs after fork, which triggers
# singal TERM at childs and calls server_close() instead of
# simply exit the child.
# Note: on server startup signals are setup to trigger
# asynchronously for a short period of time (in PreForkSimple]::loop,
# run_n_children is called before run_parent)
# Net::Server::PreFork does not have this problem, because it is using
# signal HUP stop children
sub run_n_children {
    my ($self, $n)  = @_;

    my $prop  = $self->{server};

    setup_fork_signal_mask(1); # block signals

    $self->SUPER::run_n_children($n);

    setup_fork_signal_mask(0); # unblocking signals for parent
}

# test sig_hup with: for ((;;)) ;do kill -HUP  `cat /run/pmgpolicy.pid`; done;
# wrapper to avoid multiple calls to sig_hup
sub sig_hup {
    my $self = shift;

    my $prop = $self->{server};

    return if defined($prop->{_HUP}); # do not call twice

    $self->SUPER::sig_hup();
}

### child process which will accept on the port
sub run_child {
    my $self = shift;

    my $prop = $self->{server};

    $self->log(4, "Child Preforked ($$)\n");

    # set correct signal handlers before enabling signals again
    $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = $SIG{HUP} = sub {
	$self->child_finish_hook;
	exit;
    };

    delete $prop->{children};

    $self->child_init_hook;

    # accept connections

    my $sock = $prop->{sock}->[0];

    # make sure we got a good sock
    if (!defined ($sock)){
	$self->log(0, "ERROR: Received a bad socket");
	exit (-1);
    }

    # sometimes the socket is not usable, don't know why
    my $flags = fcntl($sock, F_GETFL, 0);
    if (!$flags) {
	$self->log(0, "socket not ready - $!");
	exit (-1);
    }

    # cache is limited, because postfix does max. 100 queries
    $self->{cache} = {};

    eval {
	my $mux = $self->{mux};
	$mux->listen ($sock);
	$mux->loop;
    };
    if (my $err = $@) {
	$self->log(0, "ERROR: $err");
    }

    $self->child_finish_hook;

    exit;
}

my $syslog_map = {
    0 => 'err',
    1 => 'warning',
    2 => 'notice',
    3 => 'info',
    4 => 'debug'
};

sub log {
    my ($self, $level, $msg, @therest) = @_;

    my $prop = $self->{server};

    return if $level =~ /^\d+$/ && $level > $prop->{log_level};

    $level = $syslog_map->{$level} || $level;
    if (@therest) {
        syslog($level, $msg, @therest);
    } else {
	syslog ($level, $msg);
    }
}

my $server = bless {
    server => $server_attr,
};

$server->sig_chld(); # avoid zombies after restart

$server->run ();

exit (0);

__END__

=head1 NAME

pmgpolicy - The Proxmox policy daemon

=head1 SYNOPSIS

pmgpolicy

=head1 DESCRIPTION

Documentation is available at www.proxmox.com