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

use HTTP::Daemon;
use HTTP::Status;
use URI::Escape qw(uri_unescape);
use Qmail::Deliverable ':all';
use Getopt::Long;
Getopt::Long::Configure("bundling");

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

if (@ARGV and $ARGV[0] !~ /^-/) {
    warn "WARNING: Using deprecated old style command line argument parsing. Update your startup scripts!\n";

    ($listen, $pidfile) = @ARGV;
} else {
    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;
}


fork && exit unless $foreground;

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

my $d = HTTP::Daemon->new(
    LocalAddr => $listen,
    ReuseAddr => 1,
) or die "Could not start daemon ($!)";

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

$SIG{HUP} = sub {
    warn "SIGHUP received.\n";
    reread_config;
    warn "Qmail configuration reloaded.\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;
        while (my $r = $c->get_request) {
            if ($r->method ne 'GET' or $r->uri->path !~ m[^/qd1/]) {
                $verbose && printf "Not a qd request: %s %s\n", $r->method, $r->uri->path;
                $c->send_error(RC_FORBIDDEN);
                next;
            }
            my (undef, undef, $command) = split m[/], $r->uri->path;

            my $arg = uri_unescape($r->uri->query) || "\0";

            ($arg) = $arg =~ /^([\x20-\x7e]*)\z/ or do {
                $verbose && print "Invalid data received.\n";
                $c->send_error(RC_BAD_REQUEST);
                next;
            };

            my $rv;
            if ($command eq 'qmail_local') {
                $verbose && printf "qmail_local('%s') => ", $arg;
                $rv = eval { qmail_local($arg) };
                $verbose && printf "%s\n", $rv;
            } elsif ($command eq 'deliverable') {
                $verbose && printf "deliverable('%s') => ", $arg;
                $rv = eval { deliverable($arg) };
                $verbose && printf "0x%02x\n", $rv;
                $counter{yes}++ if $rv;
                $counter{no}++ if not $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 && print "Unknown command: %s\n", $command;
                $c->send_error(RC_FORBIDDEN);
                next;
            }
            if (defined $rv) {
                $c->send_response( HTTP::Response->new(200, "OK", undef, $rv) );
            } else {
                $c->send_response( HTTP::Response->new(204, "UNDEF", undef, "undef") );
            }

        }
        $c->close;
        undef($c);
    }
    sleep 5;
}

__END__

=head1 NAME

qmail-deliverabled - Deliverabitily 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.

Requires the HTTP::Daemon module, available from CPAN.

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 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 may get messy.

=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 AUTHOR

Juerd Waalboer <#####@juerd.nl>

=head1 SEE ALSO

L<Qmail::Deliverable::Client>
