File Coverage

bin/qmail-deliverabled

Criterion	Covered	Total	%
statement	26	37	70.2
branch	1	18	5.5
condition			n/a
subroutine	8	9	88.8
pod	0	1	0.0
total	35	65	53.8

#!/usr/bin/perl -Tw
use strict;

use IO::Socket::INET;
use POSIX ();
use Qmail::Deliverable ':all';
use Getopt::Long;
Getopt::Long::Configure("bundling");

my ( $pidfile, $verbose, $stop, $foreground );
my $listen = "127.0.0.1:8998";

sub _uri_unescape {
    my ($value) = @_;
    $value =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    return $value;
}

sub _send_response {
    my ( $sock, $code, $message, $body ) = @_;
    $body = '' if not defined $body;
    my $response = join "",
        "HTTP/1.0 $code $message\r\n",
        "Content-Length: " . length($body) . "\r\n",
        "Content-Type: text/plain\r\n",
        "Connection: close\r\n",
        "\r\n",
        $body;
    print {$sock} $response;
}

sub _send_error {
    my ( $sock, $code, $message ) = @_;
    _send_response( $sock, $code, $message, "$code $message\n" );
}

GetOptions(
    "help|h"       => sub { die "Use 'man qmail-deliverabled' for full documentation.\n" },
    "verbose|v"    => \$verbose,
    "listen|l=s"   => \$listen,
    "pidfile|p:s"  => \$pidfile,
    "stop"         => \$stop,
    "foreground|f" => \$foreground,
) or exit 255;

($listen) = $listen =~ /^(stop|[0-9.]+:[0-9]+)$/
    or die "Listen argument must be ip:port!\n";

if ($pidfile) {
    ($pidfile) = $pidfile =~ m[^(/[\x20-\xff]+)$]
        or die "pidfile must be an absolute path, beginning with a /.\n";
}

chdir '/';

if ( $stop or $listen eq 'stop' ) {
    die "Cannot --stop without --pidfile.\n" if not $pidfile;
    open my $fh, '<', $pidfile or die "Could not open pidfile $pidfile: $!\n";
    my $pid = readline $fh;
    ($pid) = $pid =~ /^([2-9]|[0-9]{2,})$/
        or die "Could not read PID from $pidfile\n";
    close $fh;
    kill 15, $pid;
    sleep 1;
    kill 9, $pid;
    unlink $pidfile;
    exit;
}

# Bind the listener before daemonizing so any "address already in use"
# error surfaces in the foreground where the operator can see it.
my ( $listen_host, $listen_port ) = $listen =~ /^([0-9.]+):([0-9]+)\z/
    or die "Listen argument must be ip:port!\n";
my $d = IO::Socket::INET->new(
    LocalAddr => $listen_host,
    LocalPort => $listen_port,
    Proto     => 'tcp',
    Listen    => 5,
    ReuseAddr => 1,
) or die "Could not start daemon ($!)\n";

daemonize() unless $foreground;

# pidfile is written AFTER daemonization so it records the final PID.
# Only the surviving (grand)child reaches this point.
my $cleanup_pidfile;

END {
    unlink $cleanup_pidfile
        if defined $cleanup_pidfile && -e $cleanup_pidfile;
}

if ($pidfile) {
    open my $fh, '>', $pidfile
        or die "Could not open pidfile $pidfile: $!\n";
    print {$fh} $$
        or die "Could not write to pidfile $pidfile: $!\n";
    close $fh
        or die "Could not close pidfile $pidfile: $!\n";
    $cleanup_pidfile = $pidfile;
}

$SIG{TERM} = $SIG{INT} = sub { exit 0 };
$SIG{HUP}  = sub {
    warn "SIGHUP received.\n";
    reread_config;
    warn "Qmail configuration reloaded.\n";
};
$SIG{PIPE} = 'IGNORE';    # broken client mid-response should not kill us

$verbose && print "My PID is $$.\n";

my ($base0) = $0 =~ /([\x20-\x7f]+)/;
my %counter;
$counter{yes} = $counter{no} = 0;

$| = 1;

for ( ;; ) {
    $verbose && printf "Listening on %s.\n", $listen;
    while ( my $c = $d->accept ) {
        $verbose && printf "Accepted request from %vd.\n", $c->peeraddr;
        my $request_line = <$c>;
        if ( not defined $request_line ) {
            $c->close;
            undef($c);
            next;
        }

        while ( my $line = <$c> ) {
            last if $line =~ /^\r?\n\z/;
        }

        my ( $method, $target ) = $request_line =~ /^([A-Z]+) ([\x21-\x7e]+) HTTP\/1\.[01]\r?\n\z/;
        if ( not defined $method or $method ne 'GET' or $target !~ m[^/qd1/] ) {
            $verbose && print "Not a qd request.\n";
            _send_error( $c, 403, "Forbidden" );
            $c->close;
            undef($c);
            next;
        }

        my ( $command, $raw_query ) = $target =~ m{\A/qd1/([A-Za-z_]+)(?:\?(.*))?\z};
        if ( not defined $command ) {
            $verbose && print "Not a qd request.\n";
            _send_error( $c, 403, "Forbidden" );
            $c->close;
            undef($c);
            next;
        }

        my $arg =
            defined $raw_query && length $raw_query
            ? _uri_unescape($raw_query)
            : "\0";

        ($arg) = $arg =~ /^([\x20-\x7e]*)\z/ or do {
            $verbose && print "Invalid data received.\n";
            _send_error( $c, 400, "Bad Request" );
            $c->close;
            undef($c);
            next;
        };

        my $rv;
        if ( $command eq 'qmail_local' ) {
            $verbose && printf "qmail_local('%s') => ", $arg;
            $rv = eval { qmail_local($arg) };
            if ($@) {
                $verbose && warn "qmail_local error: $@";
                _send_error( $c, 500, "Internal Server Error" );
                $c->close;
                undef($c);
                next;
            }
            $verbose && printf "%s\n", defined $rv ? $rv : '(undef)';
        }
        elsif ( $command eq 'deliverable' ) {
            $verbose && printf "deliverable('%s') => ", $arg;
            $rv = eval { deliverable($arg) };
            if ($@) {
                $verbose && warn "deliverable error: $@";
                _send_error( $c, 500, "Internal Server Error" );
                $c->close;
                undef($c);
                next;
            }
            $verbose && printf "%s\n", defined $rv ? sprintf( "0x%02x", $rv ) : '(undef)';
            $counter{yes}++ if $rv;
            $counter{no}++  if !$rv;
            my $total = $counter{yes} + $counter{no};
            $0 = sprintf "$base0 yes=%d(%.1f%%), no=%d(%.1f%%), total=%d",
                $counter{yes}, $counter{yes} / $total * 100,
                $counter{no},  $counter{no} / $total * 100,
                $total;
        }
        else {
            $verbose && printf "Unknown command: %s\n", $command;
            _send_error( $c, 403, "Forbidden" );
            $c->close;
            undef($c);
            next;
        }
        if ( defined $rv ) {
            _send_response( $c, 200, "OK", $rv );
        }
        else {
            _send_response( $c, 204, "UNDEF", '' );
        }
        $c->close;
        undef($c);
    }
    sleep 5;
}

# Standard double-fork daemonization: detaches from the controlling terminal,
# becomes its own session leader, and redirects standard handles to /dev/null
# so output from libraries doesn't end up on a terminal that no longer cares.
sub daemonize {
    my $pid = fork;
    die "fork: $!\n" if not defined $pid;
    exit 0           if $pid;               # original parent exits

    POSIX::setsid() != -1 or die "setsid: $!\n";

    $pid = fork;
    die "fork: $!\n" if not defined $pid;
    exit 0           if $pid;               # session leader exits

    open STDIN,  '<', '/dev/null' or die "reopen STDIN: $!\n";
    open STDOUT, '>', '/dev/null' or die "reopen STDOUT: $!\n";
    open STDERR, '>', '/dev/null' or die "reopen STDERR: $!\n";
    umask 0;
}

__END__