#!/usr/bin/perl
# High performance pre-forking qpsmtpd daemon, Copyright (C) 2006 SoftScan
# http://www.softscan.co.uk
#
# Based on qpsmtpd-forkserver Copyright (C) 2001 Ask Bjoern Hansen
# See the LICENSE file for details.
#
# For more information see http://develooper.com/code/qpsmtpd/
#
# Last updated: 05-05-2006
# Reviewed by: DA, LR

# safety guards
use strict;

# includes
use IO::Socket;
use POSIX;
use IPC::Shareable(':all');
use lib 'lib';
use Qpsmtpd::TcpServer::Prefork;
use Qpsmtpd::Constants;
use Getopt::Long;
#use Time::HiRes qw(gettimeofday tv_interval);

# secure shell
$ENV{'PATH'} = '/bin:/usr/bin';
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};

# version
my $VERSION        = "1.0";

# qpsmtpd instance
my $qpsmtpd;

#cmd's needed by IPC
my $ipcrm = '/usr/bin/ipcrm';
my $ipcs = '/usr/bin/ipcs';
my $xargs = '/usr/bin/xargs';

#vars we need
my $chld_shmem; #shared memory to keep track of children (and their connections)
my %children;
my $chld_pool;
my $chld_busy;
my $d; # socket

#default settings
my $pid_path       = '/var/run/qpsmtpd/';
my $PID            = $pid_path . "/qpsmtpd.pid";
my $user           = 'qmailq';
my $d_port         = 25;
my $d_addr         = "0.0.0.0";
my $debug          = 0;
my $max_children   = 15; #max number of child processes to spawn
my $idle_children  = 5; #number of idle child processes to spawn
my $logFile        = '/tmp/qpsmtpd_daemon.log';
my $maxconnip      = 10;
my $child_lifetime = 100; #number of times a child may be reused
my $loop_sleep     = 30; #max number of seconds main_loop sleeps before checking for busy children
my $re_nice        = 5; #nice process (parent process is reniced with number substracted from current nice level)
my $d_start        = 0; 
my $quiet          = 0;
my $status         = 0;
my $signal         = ''; 

# help text
sub usage
{
	print <<"EOT";
Usage: qpsmtpd-highperf [ options ]
--start             : Start daemon
--stop              : Kill daemon (and spawned children)
--reload            : Reload daemon (does not break current connections)
--status            : Show daemon status
--quiet             : Be quiet (even errors are suppressed)
--version	    : Show version information
--debug             : Enable debug output
--debug-path path   : Path to debug file (default: $logFile)
--interface addr    : Interface daemon should listen on (default: $d_addr)
--port int          : TCP port daemon should listen on (default: $d_port)
--max-from-ip int   : Limit number of connections from single IP (default: $maxconnip, 0 to disable)
--children int      : Max number of children that can be spawned (default: $max_children)
--idle-children int : Number of idle children to spawn (default: $idle_children, 0 to disable)
--user username     : User the daemon should run as (default: $user)
--pid-file path	    : Path to pid file
--renice-parent int : Subtract value from parent process nice level (default: $re_nice)
--help              : This message
EOT
	exit 0;
}

# get arguments
GetOptions(
	'start'            => \$d_start,
	'stop'             => sub { $signal = 'TERM' },
	'reload'           => sub { $signal = 'HUP' },
	'status'           => \$status,
	'quiet'            => \$quiet,
	'version'          => sub { print "Qpsmtpd Daemon - version $VERSION\n"; exit 0; },
	'debug'            => \$debug,
	'debug-path=s'     => \$logFile,
	'interface=s'      => \$d_addr,
        'port=i'     => \$d_port,
	'max-from-ip=i'    => \$maxconnip,
	'children=i'       => \$max_children,
	'idle-children=i'  => \$idle_children,
	'user=s'           => \$user,
        'pid-file=s' => \$PID,
	'renice-parent=i'  => \$re_nice,
	'help'             => \&usage,
) || &usage;

# check arguments
if ( !$d_start && !$signal && !$status ) {
    print "Wrong aguments!\nSee qpsmtpd-highperf --help for information on options\n";
    exit 1;
}

# misc checks
$maxconnip = $max_children if ($maxconnip == 0); #set max from ip to max number of children if option is set to disabled
$maxconnip++; #to fix limit counter error in plugin <hosts_allow>
$idle_children = $max_children if ( !$idle_children || $idle_children > $max_children || $idle_children < -1 ); #ensure that idle_children matches value given to max_children
$chld_pool = $idle_children;

# show status
if ($status) {
	my $p = get_pid($PID);
  if ($p) {
    print "daemon is running (pid: $p)...\n";
  } else {
    print "daemon is stopped...\n";
  }
  exit 0;
}

#start daemon
if ($d_start) {
    # check if another instance is running (exit if yes)
    my $p = get_pid($PID);
    if ($p) {
    	if (kill 0, $p) {
        print "Daemon is already running (pid: $p)\n";
        exit 1;
      } else {
        info("delete stale PID file <$PID> and cleanup shared memory");
        unlink("$PID") || die "can not delete stale PID file <$PID>";
        #check for muribund shared memory
        my $T_shmid = `$ipcs -pm | $xargs`;
        if ($T_shmid =~ /(\d+)\s+$user\s+$p\s+\d+$/) {
        	my $shmid = $1;
        	my ($semid, $shmid_key);
        	open(SEMID, "$ipcs -sm |");
        	while(<SEMID>) {
        		$shmid_key = $1 if (/^(0x\w+)\s+$shmid/);
        		$semid = $1 if ($shmid_key && /^$shmid_key\s+(\d+)/);
        	}
        	close(SEMID);
          system("$ipcrm -m $shmid -s $semid");
        }
      }
    }

    # get UUID/GUID
    my ( $uuid, $ugid, $group );
    my $T_uuid  = `id -u $user`;
    my $T_ugid  = `id -g $user`;
    my $T_group = `id -n -g $user`;
    chomp($T_uuid);
    chomp($T_ugid);
    chomp($T_group);

    # make the following vars taint happy
    $uuid  = $1 if ( $T_uuid  =~ /(\d+)/ );
    $ugid  = $1 if ( $T_ugid  =~ /(\d+)/ );
    $group = $1 if ( $T_group =~ /(\w+)/ );
    die("FATAL: unknown user <$user> or missing group information")
      if ( !$uuid || !$ugid );

    # check directory structure
    if ( $PID =~ /$pid_path/ and !-d $pid_path ) {
        system("mkdir -p $pid_path");
        system("chown $user.$group $pid_path");
    }
    system "chown", "$user.$group", $logFile if ( -f "$logFile" );

    # create new socket (used by clients to communicate with daemon)
    $d = new IO::Socket::INET(
        LocalPort => $d_port,
        LocalAddr => $d_addr,
        Proto     => 'tcp',
        Listen    => SOMAXCONN,
        Reuse     => 1,
    );
    die "FATAL: Failed to start daemon.\nReason: $!\n(It may be nessesary to ".
        "wait 20 secs before starting daemon again)\n" unless $d;

    info("qpsmtpd-highperf daemon, version: $VERSION, staring on host: $d_addr, port: $d_port (user: $user [$<])");

    #reset priority
    my $old_nice = getpriority(0, 0);
    my $new_nice = $old_nice - $re_nice;
    if ($new_nice < 20 && $new_nice > -20) {
	    setpriority(0, 0, $1) if ( $new_nice =~ /(\-?\d+)/ );
	    info("parent daemon nice level: $1");
    } else {
	    die "FATAL: new nice level: $new_nice is not between -19 and 19 (old level = $old_nice, renice value = $re_nice)";
    }
        
    # change UUID/UGID
    $) = "$ugid $ugid";    # effective gid
    $( = $ugid;            # real gid
    $> = $uuid;            # effective uid
    $< = $uuid;            # real uid. we now cannot setuid anymore
    die "FATAL: failed to setuid to user: $user, uid: $uuid\n"
      if ( $> != $uuid and $> != ( $uuid - 2**32 ) );        
        
    # daemonize
    &daemonize;

    #setup shared memory
    $chld_shmem = &shmem("qpsmtpd", 1);
    untie $chld_shmem;
    
    #setup qpsmtpd_instance
    $qpsmtpd = &qpmsptd_instance();

    #child reaper
    $SIG{CHLD} = \&reaper;
    &spawn_children;
    &main_loop;
    exit;
}

#stop/reload daemon
if ($signal) {
    $SIG{TERM} = $SIG{HUP} = 'IGNORE'; #prevent signals to ourself
    my $p = get_pid($PID);
    if ($p) {
    	kill $signal => $p;
    } else {
    	print "Unable to $signal daemon...\nQpsmtpd-highperf isn't running!\n";
    }
    exit;
}

#setup daemon process
sub daemonize {
	
	  #redirect std filehandles to the bit bucket
    open STDIN, "</dev/null" || die "Can't read from: /dev/null - $!\n";
    open STDOUT, ">/dev/null" || die "Can't write to: /dev/null - $!\n";
	
    my $pid = fork;
    defined($pid) or die "Can't start daemon: $!";

    #if this is the shell-called process, let clients know the daemon is now running and detach
    if ($pid) {

      #write PID file
      open( PID, "> $PID" ) || die "can't write to file <$PID> - $!";
      print PID "$pid\n";
      close PID;

      #exit back to shell
      exit;
    }

    #now we're a daemonized parent process!

    #detach from shell, by setting session and making process group
    POSIX::setsid();

    #redirect errors (too)
    open STDERR, '>&STDOUT' || die "Can't duplicate stdout - $!\n";
    
    #set pretty parent name in process listing
    #$0 = "$0 " . "@ARGV";

    # Set up signals that should be catched
    $SIG{__WARN__} = sub {
        info( "WARN: " . join( " ", @_ ) ) if ( !$quiet );
    };

    $SIG{__DIE__} = sub {
    	  my $msg = join (" ", @_);
	      chomp($msg);
        info( "FATAL: <$msg>" ) if ( !$quiet );
        die "FATAL: <$msg> - "
    };

    $SIG{INT} = $SIG{TERM} = sub {
        # terminate daemon (and children)
        my $sig = shift;
        $SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE'; #prevent another signal and disable reaper
        unlink("$PID");
        $d->close(); #close socket
        my $cnt = kill 'INT' => keys %children;
        IPC::Shareable->clean_up; #cleanup shared memory
        info("shutdown of daemon (and $cnt children)");
        exit;
    };

    $SIG{HUP} = sub {
    	# reload qpmstpd plugins
    	$qpsmtpd->load_plugins;
    	kill 'HUP' => keys %children;
    	info("reload daemon requested" );
    };

}

# initialize children (only done at daemon startup)
sub spawn_children {
	  #block signals while new children are being spawned
	  my $sigset = &block_signal(SIGCHLD);
    for ( 1 .. $chld_pool ) {
        &new_child();
    }
    #reset block signals
    &unblock_signal($sigset);
}

# cleanup after child dies
sub reaper {
    my $stiff;
    my @stiffs;
    while ( ( $stiff = waitpid( -1, &WNOHANG ) ) > 0 ) {
        my $res = WEXITSTATUS($?);
        info("child terminated, pid: $stiff (status $?, res: $res)");
        delete $children{$stiff}; #delete pid from children
        push @stiffs, $stiff; #add pid to array so it later can be removed from shared memory
    }
    #remove connection info from shared memory
    $chld_busy = &shmem_opt(undef, \@stiffs, undef, undef); #and get number of busy children (use by main_loop)
    $SIG{CHLD} = \&reaper;
}

#main_loop: main loop (spawn new children)
#arg0: void
#ret0: void
sub main_loop {
    while (1) {
    	  #sleep EXPR seconds or until signal (i.e. child death) is received
        my $sleept = sleep $loop_sleep;
        #block CHLD signals to avoid race, anyway does it matter?
        my $sigset = &block_signal(SIGCHLD);
        $chld_busy = &shmem_opt(undef, undef, undef, undef, 1) if ($sleept == $loop_sleep); #get number of busy children, if sleep wasn't interrupted by signal
      	#calculate children in pool (if valid busy children number)
        if (defined($chld_busy)) {
          info("busy children: $chld_busy");
          $chld_pool = $chld_busy + $idle_children;
        }
        $chld_pool = $max_children if ($chld_pool > $max_children); #ensure pool limit is max_children
        #spawn children
        for ( my $i = scalar (keys %children); $i < $chld_pool ; $i++ ) {
            &new_child(); #add to the child pool
        }
        info("children pool: $chld_pool (currently spawned: ".scalar (keys %children).")");
        #unblock signals
        &unblock_signal($sigset);
    }
}

#block_signal: block signals
#arg0..n: int with signal(s) to block
#ret0: ref str with sigset (used to later unblock signal)
sub block_signal {
	my @signal = @_; #arg0..n
	
	my ($sigset, $blockset);
	
  $sigset   = POSIX::SigSet->new(); 
  $blockset = POSIX::SigSet->new(@signal);       
  sigprocmask(SIG_BLOCK, $blockset, $sigset) 
    or die "Could not block @signal signals: $!\n";	
    
  return($sigset);

}

#unblock_signal: unblock/reset and receive pending signals
#arg0: ref str with sigset
#ret0: void
sub unblock_signal {
	my $sigset = shift; #arg0
	
  sigprocmask(SIG_SETMASK, $sigset)
    or die "Could not restore signals: $!\n";	
	
}

#new_child: initialize new child
#arg0: void
#ret0: void
sub new_child {

    # daemonize away from the parent process
    my $pid;
    die "Cannot fork child: $!\n" unless defined( $pid = fork );
    if ($pid) {
    	# in parent
    	$children{$pid} = 1;
      info("new child, pid: $pid");
      return;
    }
    # in child
    
    #reset priority
    setpriority 0, 0, getpriority (0, 0) + $re_nice;

    # reset signals
    my $sigset   = POSIX::SigSet->new(); 
    my $blockset = POSIX::SigSet->new(SIGCHLD);
    sigprocmask(SIG_UNBLOCK, $blockset, $sigset) 
      or die "Could not unblock SIGHUP signal: $!\n";	
    $SIG{CHLD} = $SIG{INT} = $SIG{TERM} = $SIG{ALRM} = 'DEFAULT';

    # child should exit if it receives HUP signal (note: blocked while child is busy, but restored once done)
    $SIG{HUP} = sub {  info("signal HUP received, going to exit");
                     	 exit 1;
                    };
                    
    # continue to accept connections until "old age" is reached
    for ( my $i = 0; $i < $child_lifetime ; $i++ ) {
  
      # accept a connection
      $0 = 'qpsmtpd child'; # set pretty child name in process listing
      my ($client, $iinfo) = $d->accept() or die "failed to create new object - $!"; # wait here until client connects
      info("connect from: " . $client->peerhost . ":" . $client->peerport );
    
      # set STDIN/STDOUT and autoflush
      POSIX::dup2(fileno($client), 0) || die "unable to duplicate filehandle to STDIN - $!";
      POSIX::dup2(fileno($client), 1) || die "unable to duplicate filehandle to STDOUT - $!";
      $| = 1;

      #connection recieved, block signals
      my $sigset = &block_signal(SIGHUP);
      	      	
    	#start new qpsmtpd session
    	&qpsmtpd_session($client, $qpsmtpd) if ($iinfo); #only start a session if connection looks valid
    	
    	#close connection and cleanup
      $client->shutdown(2);
      
      #unset block and receive pending signals
      &unblock_signal($sigset);

    }
    exit;    # this child has reached its end-of-life
}

# respond to client
# arg0: ref to socket object (client) 
# arg1: int with SMTP reply code
# arg2: arr with message
# ret0: int 0|1 (0 = failure, 1 = success)
sub respond_client {
  my ($client, $code, @message) = @_;
  $client->autoflush(1);
  while (my $msg = shift @message) {
    my $line = $code . (@message?"-":" ").$msg;
    info("reply to client: <$line>");
    print $client "$line\r\n" 
      or (&info("Could not print [$line]: $!"), return 0);
  }
  return 1;
}

#get_pid: get pid of running qpsmtpd-highperf process
#arg0: str with path to pid file
#ret0: int with pid (undef if process isn't running or unable to get pid from file)
sub get_pid {
  my $pid_path = shift; #arg0
  
  open(PID, "<$pid_path") || return;
  my $p = <PID>;
  close(PID);
  $p = $1 if ($p =~ /^(\d+)$/);	
  
  return($p);
}

#qpsmtpd_instance: setup qpsmtpd instance
#arg0: void
#ret0: ref to qpsmtpd_instance
sub qpmsptd_instance {
	
    my $qpsmtpd = Qpsmtpd::TcpServer::Prefork->new();
    $qpsmtpd->load_plugins;
    $qpsmtpd->spool_dir;
    $qpsmtpd->size_threshold;

    return($qpsmtpd);
}

#shmem: tie to shared memory hash
#arg0: str with glue
#arg1: int 0|1 (0 = don't create shmem, 1 = create shmem)
#ret0: ref to shared hash
sub shmem {
	my $glue   = shift; #arg0
	my $create = shift || 0; #arg1
	
  my %options = (
     create    => $create,
     exclusive => 0,
     mode      => 0640,
     destroy   => 0,
     );
	
	my %shmem_hash;
	eval {
	  tie %shmem_hash, 'IPC::Shareable', $glue, { %options } || die "unable to tie to shared memory - $!";
	};
	if ($@) {
		info("$@");
		return;
	}
	
	return(\%shmem_hash);
}

#shmem_opt: connect to shared memory and perform options
#arg0: ref to hash where shared memory should be copied to
#arg1: ref to arr with pid(s) to delete
#arg2: int with pid to add (key)
#arg3: str with packed iaddr to add (value)
#arg4: int 0|1 check and cleanup shared memory (0 = no, 1 = yes - default 0)
#ret0: int with number of busy children (undef if error)
sub shmem_opt {
	my $ref_shmem     = shift; #arg0
	my $ref_pid_del   = shift; #arg1
	my $pid_add_key   = shift; #arg2
	my $pid_add_value = shift; #arg3
	my $check         = shift || 0; #arg4
	
	#check arguments
	return if ( (defined($pid_add_key) && !defined($pid_add_value)) || (!defined($pid_add_key) && defined($pid_add_value)) );
	
	my ($chld_shmem, $chld_busy);
	eval {
  	$chld_shmem = &shmem("qpsmtpd", 0); #connect to shared memory hash
  	
    if (tied %{$chld_shmem}) {
    	#perform options
      (tied %{$chld_shmem})->shlock(LOCK_EX);
      #delete
      if ($ref_pid_del) {
        foreach my $pid_del (@{$ref_pid_del}) {
          delete $$chld_shmem{$pid_del};
        }
      }
      $$chld_shmem{$pid_add_key} = $pid_add_value if ($pid_add_key); #add
      %{$ref_shmem} = %{$chld_shmem} if($ref_shmem); #copy
      #loop through pid list and delete orphaned processes
      if ($check) {
      	foreach my $pid (keys %{$chld_shmem}) {
      		if (! kill 0, $pid) {
      			delete $$chld_shmem{$pid};
      			warn("orphaned child, pid: $pid - removed from shared memory");
      		}
      	}
      }
      #count number of busy children
      $chld_busy = scalar(keys %{$chld_shmem});
      (tied %{$chld_shmem})->shunlock;
      untie $chld_shmem || die "unable to untie from shared memory"; #untie from shared memory
    }
  };
  #check for error
  if ($@) {
  	undef($chld_busy);
  	warn("$@");
  }
  
  return($chld_busy);
}

# info: write info
# arg0: str with debug text
sub info {
    my $text = shift; #arg0
    return if ( !$debug );

    my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime(time);
    my $nowtime = sprintf "%02d/%02d/%02d %02d:%02d:%02d", $mday, $mon + 1,
      $year + 1900, $hour, $min, $sec;

    chomp($text);
    system("echo \"$nowtime:$$: $text\" >> $logFile");
}

#start qpmstpd session
# arg0: ref to socket object
# arg1: ref to qpsmtpd instance
# ret0: void
sub qpsmtpd_session {
	  my $client  = shift; #arg0
	  my $qpsmtpd = shift; #arg1
	  
	  #get local/remote hostname, port and ip address
	  my ($port, $iaddr)  = sockaddr_in(getpeername($client)); #remote
    my ($lport, $laddr) = sockaddr_in(getsockname($client)); #local

    #get current connected ip addresses (from shared memory)
    my %children;
    &shmem_opt(\%children, undef, $$, $iaddr);
    
    my ($rc, @msg) = $qpsmtpd->run_hooks("pre-connection",
                                         remote_ip    => inet_ntoa($iaddr),
                                         remote_port  => $port,
                                         local_ip     => inet_ntoa($laddr),
                                         local_port   => $lport,
                                         max_conn_ip  => $maxconnip,
                                         child_addrs  => [values %children],
                                        );
    if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT || $rc == DENY || $rc == DENY_DISCONNECT ) {
    	my $rc_reply = 451; #smtp return code to reply client with (seed with soft deny)
      unless ($msg[0]) {
      	if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
          @msg = ("Sorry, try again later");
        } else {
        	@msg = ("Sorry, service not available to you");
        	$rc_reply = 550;
        }
      }
      &respond_client($client, $rc_reply, @msg);
      &shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory
      return; #retur so child can be reused
    }
    
    # all children should have different seeds, to prevent conflicts
    srand( time ^ ($$ + ($$ << 15)) );
  
#   $SIG{$_} = 'DEFAULT' for keys %SIG;
    $SIG{ALRM} = sub { 
                      print $client "421 Connection Timed Out\n";
                      &info("Connection Timed Out"); 
                      exit 1; #this will kill the child, but who cares?
                     };
  
    #set enviroment variables
    $ENV{TCPLOCALIP}    = inet_ntoa($laddr);
    $ENV{TCPREMOTEIP}   = inet_ntoa($iaddr);
    $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown";

    #run qpmsptd functions
    $SIG{__DIE__} = 'DEFAULT';
    eval {
      $qpsmtpd->start_connection (
                                  local_ip    => $ENV{TCPLOCALIP},
                                  local_port  => $lport,
                                  remote_ip   => $ENV{TCPREMOTEIP},
                                  remote_port => $client->peerport,
                                 );
      $qpsmtpd->run();
      $qpsmtpd->run_hooks("post-connection");
    };
    if($@ !~ /^(disconnect_tcpserver|died while reading from STDIN)/ ) {
    	warn("$@");
    }

    #done - this child is now idle again
    &shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory
    
    info("remote host: $ENV{TCPREMOTEIP} left...");

}