#!/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__

=head1 NAME

qmail-deliverabled - Deliverability check daemon

=head1 USAGE

    qmail-deliverabled [--listen 127.0.0.1:8998] [--pidfile /foo/bar.pid]
    qmail-deliverabled --stop --pidfile /foo/bar.pid

    --stop          Kill the process in the given --pidfile
    --listen        IP and port to listen on, defaults to 127.0.0.1:8998
    --foreground    Don't daemonize, but stay in the foreground
    --verbose       Print debug information while running
    --help          Print usage information and exit.
    --pidfile       Write a pidfile (unless --stop is also given)

=head1 DESCRIPTION

Exposes the Qmail::Deliverable functions C<qmail_local> and C<deliverable>
over HTTP. Typically requires root access for file permissions.

Use only with a ::Client of the same version. Returns 403 FORBIDDEN on error,
any error.

A simple init.d-style script is provided in the .tar.gz, in the init.d
directory.

=head1 SIGNALS

=over 4

=item SIGHUP

Re-read C</var/qmail/control/locals>, C</var/qmail/control/virtualdomains>,
and C</var/qmail/users/assign> without restarting.

=item SIGTERM, SIGINT

Shut down cleanly. The pidfile (if any) is removed before exit.

=back

=head1 CAVEATS

The PIDFILE is not used to avoid concurrent processes: it's perfectly fine to
have multiple qmail-deliverableds running on different addresses or ports, but
make sure each combination has its own PIDFILE.

Verbose mode is only useful when also running with C<--foreground>; once
daemonized, standard handles are redirected to /dev/null and verbose output
is silently discarded.

=head1 LEGAL

This software does not come with warranty or guarantee of any kind. Use it at
your own risk.

This software may be redistributed under the terms of the GPL, LGPL, modified
BSD, or Artistic license, or any of the other OSI approved licenses listed at
http://www.opensource.org/licenses/alphabetical. Distribution is allowed under
all of these these licenses, or any smaller subset of multiple or just one of
these licenses.

When using a packaged version, please refer to the package metadata to see
under which license terms it was distributed. Alternatively, a distributor may
choose to replace the LICENSE section of the documentation and/or include a
LICENSE file to reflect the license(s) they chose to redistribute under.

=head1 AUTHORS

=over 4

=item *

Juerd Waalboer <#####@juerd.nl> (original author)

=item *

Matt Simerson <msimerson@cpan.org> (current maintainer)

=back

=head1 CONTRIBUTORS

=over 4

=item *

Martin Sluka

=back

=head1 SEE ALSO

L<Qmail::Deliverable::Client>
