#!/usr/bin/perl -w

use strict;
use Carp;
use Getopt::Long;
use Proxmox::SafeSyslog;
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 Proxmox::Utils;
use Proxmox::RuleDB;
use Proxmox::Config::System;
use Proxmox::Commtouch;
use Proxmox::Cluster;

use vars qw(@ISA);
@ISA = 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_policy_port = 10022;
my $opt_max_dequeue = 1;
my $opt_dequeue_time = 60*2;

my $opt_testmode;
my $opt_pidfile;
my $opt_database;

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

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

initlog ('proxpolicy', 'mail');

if (!$opt_testmode) {

    my $system_cfg = Proxmox::Config::System->new ();
    my $demo = $system_cfg->get ('administration', 'demo');

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

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

my $max_servers = Proxmox::Utils::get_max_policy ();

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 run_dequeue {
    my $self = shift;

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

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

    my $system_cfg = Proxmox::Config::System->new ();

    my $cinfo = $system_cfg->clusterinfo();
    my $lcid = $cinfo->{local}->{cid};
  
    my $dbh;
    
    eval {
	$dbh = Proxmox::Utils::open_ruledb ($database);
    };
    my $err = $@;

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

    my $now = time ();

    my $ecount = 0;

    # update RBL stats in DailyStats table
    # only write if on master node
    if ($cinfo->{local}->{role} eq '-' || $cinfo->{local}->{role} eq 'M') {
	eval {
	    my $stats = Proxmox::Commtouch::get_ctipd_stats();
	    Proxmox::Cluster::update_rbl_stats($dbh, 'localhost', $stats);
	};
	if (my $err = $@) {
	    $self->log (0, "ERROR: update_rbl_stats - %s", $err);
	}
    };

    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 ($cinfo->{local}->{role} eq 'M') { 	
		# 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, msgquote ($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 = $@;

    my ($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, msgquote ($err));
    } else {
	$self->log (2, "end greylist database maintainance ($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 $system_cfg = Proxmox::Config::System->new ();
  $self->{use_rbl} = $system_cfg->get ('mail', 'use_rbl');
  $self->{use_spf} = $system_cfg->get ('mail', 'spf');
  $self->{use_greylist} = $system_cfg->get ('mail', 'greylist');
  my $hostname = $system_cfg->get ('dns', 'hostname');
  my $domain = $system_cfg->get ('dns', 'domain');
  $self->{fqdn} = "$hostname.$domain";
  my $cinfo = $system_cfg->clusterinfo();
  my $lcid = $cinfo->{local}->{cid};
  $self->{cinfo} = $cinfo;
  $self->{lcid} = $lcid;

  my $lic = $system_cfg->{license};
  $self->{lic_valid} = ($lic->valid && !$lic->expired) ? 1 : 0;

  my $dbh;

  eval {
      $dbh = Proxmox::Utils::open_ruledb ($database);

      $self->{ruledb} = Proxmox::RuleDB->new ($dbh);
      $self->{rulecache} = Proxmox::RuleDB::RuleCache->new ($self->{ruledb});
  };

  my $err = $@;

  if ($err) {
      $self->log (0, msgquote ("ERROR: unable to load database : $err"));
  }

  $self->{reload_config} = 0; 
}

sub child_init_hook {
  my $self = shift;
  my $prop = $self->{server};

  $0 = 'proxpolicy child';

  setup_fork_signal_mask (0); # unblocking signals for children

  eval {
      $self->load_config ();

      $self->{mux} = new IO::Multiplex;
      $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 ($@) {
      $self->log (0, msgquote ($@));
      $self->child_finish_hook;
      exit;
  }

  $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 = Proxmox::Utils::open_ruledb ($database);
	};
	my $err = $@;
	if ($err) {
	    $self->log (0, msgquote ("unable to reconnect to database server: $err"));
	    return 'dunno';
	}
	$self->{ruledb} = Proxmox::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';
    }

    # we run commtouch test first for now
    # only run with valid license
    # NOTE: disabled - we use rbl_reject in postfix main.cf
    if (0 && !$opt_testmode && $self->{use_rbl} && $self->{lic_valid}) { 
	my ($ct_action, $ct_refid);
	my ($csec, $usec) = gettimeofday ();
	eval {
	    ($ct_action, $ct_refid) = Proxmox::Commtouch::ct_scan_ip($ip);
	};
	my $err = $@;

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

	if ($err) {
	    $self->log (0, "ctipd error: $err ($ptime ms)");
	} elsif ($ct_action && $ct_refid) {
	    if ($ct_action ne 'accept') {
		$self->log (3, "ctipd action: $ct_action ($ip, $ct_refid, $ptime ms)");
		if ($ct_action eq 'tempfail') {
		    my $msg = "delivery from $ip is deferred and despite repeated attempts, this message could not be delivered. Try again later and if same response, then check your IP reputation at http://www.commtouch.com/Site/Resources/Check_IP_Reputation.asp and make sure to provide the following reference code '${ct_refid}'";
		    return "defer_if_permit $msg";   
		} elsif ($ct_action eq 'permfail') {
		    my $msg = "delivery from $ip is rejected. Check your IP reputation at http://www.commtouch.com/Site/Resources/Check_IP_Reputation.asp and make sure to provide the following reference code '${ct_refid}'";
		    return "reject $msg"; 
		}
	    }	
	}
    }

    # 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+)/;
    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);
	};
	
	my $err = $@;

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

	if ($err) {
            $err = $err->text if UNIVERSAL::isa ($err, 'Mail::SPF::Exception');
	    $self->log (0, msgquote ($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 ("SELECT merge_greylist(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", undef, 
				  $net, $host, $sender, $rcpt, $instance,
				  $ctime, $ctime + 10, 0, 100000, 0, $ctime, $self->{lcid});
		    }

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

	return $spf_result if $spf_result;
    }


    my $res = $spf_header ? "prepend $spf_header" : 'dunno';

    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 ("SELECT merge_greylist(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", 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 ($@) {
	    $dbh->rollback;
	    $self->log (0, msgquote ($@));
    }

    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);
}

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

    eval {
	$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}));
		    };
		    
		    $self->log (0, msgquote ($@)) if $@;
		}

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

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

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

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

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};     
  }
}

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  = shift;
    my $prop  = $self->{server};
    my $n     = shift;

    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 /var/run/proxpolicy.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, msgquote ("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;
  };
  
  $self->log (0, msgquote ("ERROR: $@")) if $@;

  $self->child_finish_hook;

  exit;
}

sub log {
    my ($self, $level, $msg, @therest) = @_;
    my $prop = $self->{server};

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

    $level = $Proxmox::SafeSyslog::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
                                          
proxpolicy - the Proxmox policy daemon

=head1 SYNOPSIS

proxpolicy

=head1 DESCRIPTION

Documentation is available at www.proxmox.com