qpsmtpd/qpsmtpd

#!/usr/bin/perl -w

use lib "./lib";
BEGIN {
    delete $ENV{ENV};
    delete $ENV{BASH_ENV};
    $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin';
}

use strict;
use vars qw($DEBUG);
use FindBin;
use lib "$FindBin::Bin/lib";
use Danga::Socket;
use Danga::Client;
use Qpsmtpd::PollServer;
use Qpsmtpd::Constants;
use IO::Socket;
use Carp;
use POSIX qw(WNOHANG);
use Getopt::Long;

$|++;

# For debugging
# $SIG{USR1} = sub { Carp::confess("USR1") };

use Socket qw(IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET);

$SIG{'PIPE'} = "IGNORE";  # handled manually

$DEBUG          = 0;
my $PORT        = 2525;
my $LOCALADDR   = '0.0.0.0';
my $LineMode    = 0;
my $PROCS       = 1;
my $MAXCONN     = 15;           # max simultaneous connections
my $USER        = 'smtpd';      # user to suid to
my $MAXCONNIP   = 5;            # max simultaneous connections from one IP

sub help {
    print <<EOT;
Usage:
    qpsmtpd [OPTIONS]

Options:
 -l, --listen-address addr : listen on a specific address; default 0.0.0.0
 -p, --port P              : listen on a specific port; default 2525
 -c, --limit-connections N : limit concurrent connections to N; default 15
 -u, --user U              : run as a particular user; defualt 'smtpd'
 -m, --max-from-ip M       : limit connections from a single IP; default 5
 -f, --forkmode            : fork a child for each connection
 -j, --procs J             : spawn J processes; default 1
 -h, --help                : this page

NB: -f and -j are mutually exclusive. If -f flag is not used the server uses
poll() style loops running inside J child processes. Set J to the number of
CPUs you have at your disposal.

EOT
    exit(0);
}

GetOptions(
    'p|port=i'              => \$PORT,
    'l|listen-address=s'    => \$LOCALADDR,
    'j|procs=i'             => \$PROCS,
    'd|debug+'              => \$DEBUG,
    'f|forkmode'            => \$LineMode,
    'c|limit-connections=i' => \$MAXCONN,
    'm|max-from-ip=i'       => \$MAXCONNIP,
    'u|user=s'              => \$USER,
    'h|help'                => \&help,
) || help();

# detaint the commandline
if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help }
if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help }
if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help }
if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help }
if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help }

$PROCS = 1 if $LineMode;
# This is a bit of a hack, but we get to approximate MAXCONN stuff when we
# have multiple children listening on the same socket.
$MAXCONN /= $PROCS;
$MAXCONNIP /= $PROCS;

Danga::Socket::init_poller();

my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : 
                    $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()");

my $server;

# Code for inetd/tcpserver mode
if ($ENV{REMOTE_HOST}) {
    run_as_inetd();
    exit(0);
}

my %childstatus = ();

run_as_server();
exit(0);

sub _fork {
    my $pid = fork;
    if (!defined($pid)) { die "Cannot fork: $!" }
    return $pid if $pid;

    # Fixup Net::DNS randomness after fork
    srand($$ ^ time);
    
    local $^W;
    delete $INC{'Net/DNS/Header.pm'};
    require Net::DNS::Header;
    
    # cope with different versions of Net::DNS
    eval {
        $Net::DNS::Resolver::global{id} = 1;
        $Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID()));
        # print "Next DNS ID: $Net::DNS::Resolver::global{id}\n";
    };
    if ($@) {
        # print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n";
    }
    
    # Fixup lost kqueue after fork
    $Danga::Socket::HaveKQueue = undef;
    Danga::Socket::init_poller();
}

sub spawn_child {
    _fork and return;
    
    $SIG{CHLD} = "DEFAULT";

    Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler);
    Qpsmtpd::PollServer->EventLoop();
    exit;
}

sub sig_chld {
    $SIG{CHLD} = 'IGNORE';
    while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
        last unless $child > 0;
        print "child $child died\n";
        delete $childstatus{$child};
    }
    return if $LineMode;
    # restart a new child if in poll server mode
    spawn_child();
    $SIG{CHLD} = \&sig_chld;
}

sub HUNTSMAN {
  $SIG{CHLD} = 'DEFAULT';
  kill 'INT' => keys %childstatus;
  exit(0);
}

sub run_as_inetd {
    $LineMode = 1;
    
    my $insock = IO::Handle->new_from_fd(0, "r");
    IO::Handle::blocking($insock, 0);

    my $outsock = IO::Handle->new_from_fd(1, "w");
    IO::Handle::blocking($outsock, 0);

    my $client = Danga::Client->new($insock);

    my $out = Qpsmtpd::PollServer->new($outsock);
    $out->load_plugins;
    $out->init_logger;
    $out->input_sock($client);
    my $rc = $out->start_conversation;
    if ($rc != DONE) {
        return;
    }

    $client->watch_read(1);
    while (1) {
        my $line = $client->get_line;
        last if !defined($line);
        my $output = $out->process_line($line);
        $out->write($output) if $output;
        $client->watch_read(1);
    }
}

sub run_as_server {
    # establish SERVER socket, bind and listen.
    $server = IO::Socket::INET->new(LocalPort => $PORT,
                                    LocalAddr => $LOCALADDR,
                                    Type      => SOCK_STREAM,
                                    Proto     => IPPROTO_TCP,
                                    Blocking  => 0,
                                    Reuse     => 1,
                                    Listen    => 10 )
                                           or die "Error creating server $LOCALADDR:$PORT : $@\n";

    IO::Handle::blocking($server, 0);
    binmode($server, ':raw');

    # Drop priviledges
    my (undef, undef, $quid, $qgid) = getpwnam $USER or
          die "unable to determine uid/gid for $USER\n";
    $) = "";
    POSIX::setgid($qgid) or
          die "unable to change gid: $!\n";
    POSIX::setuid($quid) or
          die "unable to change uid: $!\n";
    $> = $quid;
    
    ::log(LOGINFO, 'Running as user '.
        (getpwuid($>) || $>) .
        ', group '.
        (getgrgid($)) || $)));

    # Load plugins here
    my $plugin_loader = Qpsmtpd::SMTP->new();
    $plugin_loader->load_plugins;
    
    if ($PROCS > 1) {
        $SIG{'CHLD'} = \&sig_chld;
        my @kids;
        for (1..$PROCS) {
            push @kids, spawn_child();
        }
        $SIG{INT} = $SIG{TERM} = sub { $SIG{CHLD} = "IGNORE"; kill 2 => @kids; exit };
        ::log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL");
        sleep while (1);
    }
    else {
        if ($LineMode) {
            $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
        }
        ::log(LOGDEBUG, "Listening on $PORT with single process $POLL" .
            ($LineMode ? " (forking server)" : ""));
        Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler);
        while (1) {
            Qpsmtpd::PollServer->EventLoop();
        }
        exit;
    }

}

# Accept a new connection
sub accept_handler {
    my $running = scalar keys %childstatus;
    while ($running >= $MAXCONN) { 
        ::log(LOGINFO,"Too many connections: $running >= $MAXCONN.");
        return;
    }

    my $csock = $server->accept();
    if (!$csock) {
        # warn("accept() failed: $!");
    }
    return unless $csock;
    binmode($csock, ':raw');

    printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock))
        if $DEBUG;

    IO::Handle::blocking($csock, 0);
    setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;

    if (!$LineMode) {
        # multiplex mode
        my $client = Qpsmtpd::PollServer->new($csock);
        my $rem_ip = $client->peer_ip_string;
        
        if ($MAXCONNIP) {
            my $num_conn = 1; # seed with current value
    
            # If we for-loop directly over values %childstatus, a SIGCHLD
            # can call REAPER and slip $rip out from under us.  Causes
            # "Use of freed value in iteration" under perl 5.8.4.
            my $descriptors = Danga::Client->DescriptorMap;
            my @obj = values %$descriptors;
            foreach my $obj (@obj) {
                local $^W;
                # This is a bit of a slow way to do this. Wish I could cache the method call.
                ++$num_conn if ($obj->peer_ip_string eq $rem_ip);
            }
            
            if ($num_conn > $MAXCONNIP) {
                ::log(LOGINFO,"Too many connections from $rem_ip: "
                             ."$num_conn > $MAXCONNIP. Denying connection.");
                $client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n");
                $client->close;
                return;
            }
        }
        
        my $rc = $client->start_conversation;
        if ($rc != DONE) {
            $client->close;
            return;
        }
        $client->watch_read(1);
        return;
    }

    # fork-per-connection mode
    my $rem_ip = $csock->sockhost();
    
    if ($MAXCONNIP) {
        my $num_conn = 1; # seed with current value

        my @rip = values %childstatus;
        foreach my $rip (@rip) {
          ++$num_conn if (defined $rip && $rip eq $rem_ip);
        }
        
        if ($num_conn > $MAXCONNIP) {
            ::log(LOGINFO,"Too many connections from $rem_ip: "
                         ."$num_conn > $MAXCONNIP. Denying connection.");
            print $csock "451 Sorry, too many connections from $rem_ip, try again later\r\n";
            close $csock;
            return;
        }
    }
    
    if (my $pid = _fork) {
        $childstatus{$pid} = $rem_ip;
        return $csock->close();
    }

    $server->close(); # make sure the child doesn't accept() new connections
    
    $SIG{$_} = 'DEFAULT' for keys %SIG;
    
    my $client = Qpsmtpd::PollServer->new($csock);
    my $rc = $client->start_conversation;
    if ($rc != DONE) {
        $client->close;
        exit;
    }
    $client->watch_read(1);

    while (1) {
        my $line = $client->get_line;
        last if !defined($line);
        my $resp = $client->process_line($line);
        # if ($resp) { print "S: $_\n" for split(/\n/, $resp) }
        $client->write($resp) if $resp;
        $client->watch_read(1);
    }

    ::log(LOGDEBUG, "Finished with child %d.\n", fileno($csock))
        if $DEBUG;
    $client->close();

    exit;
}

########################################################################

sub log {
  my ($level,$message) = @_;
  # $level not used yet.  this is reimplemented from elsewhere anyway
  warn("$$ $message\n");
}