root/bin/pl-bouncedb

#!/usr/bin/perl -w

=head1 NAME

pl-bouncedb - dump the Project Lancelot bounce database

=head1 SYNOPSIS

pl-bouncedb [-dv?] --dump [--count=BUCKETS] [--size=SECS]
    [--threshold=THRESHOLD] [--timebase=SECS] list@domain
pl-bouncedb [-dv?] --parse [--address=ADDRESS] [--parser=PARSERS]
    list@domain [MESSAGE]

=head1 DESCRIPTION

The B<pl-bouncedb> command is useful for debugging Project Lancelot's
bounce processing subsystem. B<pl-bouncedb --dump> dumps the content
of the bounce database to standard output. B<pl-bouncedb --parse>
applies the given bounce parser(s) to a message and outputs the result
(without changing the database). The message is taken either from a
file named on the command line or from standard input. If no parsers
are specified on the command line, the default set of parsers is used.

=head1 SEE ALSO

pl-incoming(1), pl-init(1), pl-subchange(1)

=head1 AUTHOR

Anselm Lingnau <anselm@anselms.net>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Anselm Lingnau. This program is free software; you
may redistribute it and/or modify it under the terms of the GNU
General Public License as published by the Free Software Foundation;
either version 2 of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, refer to
<URL:http://www.gnu.org/copyleft/gpl.html>. You may also obtain it by
writing to the Free Software Foundation, Inc., 59 Temple Place - Suite
330, Boston, MA 02111-1307, USA.

=cut

use strict;

use Config;
use File::Basename;
use Time::Piece;
use Email::MIME;

use vars qw($g_base_dir);
BEGIN {
    use FindBin qw($Bin);
    $g_base_dir = dirname($Bin);
}
use lib "$g_base_dir/lib";
use lib "$g_base_dir/lib/perl5/$Config{version}";
use lib "$g_base_dir/lib/perl5/site_perl/$Config{version}";

use Lancelot::GetOpt qw/GetOptions/;
use Pod::Usage;

use Lancelot::DB;
use Lancelot::Log qw/log/;

use Lancelot::Module::process_bounce;

my (%opts) = ( dump => 0, parse => 0, parser => '' );

GetOptions(\%opts, -argvmin => 1, "no list address specified",
                   -argvmax => 2, "too many arguments",
                   "dump?", "count|c=", "size|s=", "threshold|T=",
                   "parse?", "parser|P=", "address|a=", "timebase|t=");

pod2usage( -message => "$0: need --dump or --parse",
           -exitvalue => 2)
    if $opts{dump} + $opts{parse} != 1;

my ($listaddr) = shift;

my $db = new Lancelot::DB $listaddr
    or die "$0: error accessing list $listaddr\n";

if ($opts{dump}) {
    my $bucket_count = $opts{count} || $db->get_config("bounce.bucketcount");
    my $bucket_size = $opts{size} || $db->get_config("bounce.bucketsize");
    my $bounce_threshold = $opts{threshold} || $db->get_config("bounce.threshold");
    log_and_die "crit", "bounce hander parameter(s) missing from configuration"
        unless $bucket_count && $bucket_size && $bounce_threshold;
    my $timebase = $opts{timebase} || time;

    foreach my $address ($db->get_bounce_addresses()) {
        my $t = Lancelot::Module::process_bounce::total_score($db, $address,
                                                              $bucket_count,
                                                              $bucket_size);
        my $bounces = $db->get_bounces($address, 0);
        print "$address: ", scalar(@$bounces),
            " bounces (total score $t, bounce_threshold $bounce_threshold)\n";
        foreach my $bounce (@$bounces) {
            my ($timestamp, $score, $message) = @$bounce;
            my ($bucket) = int(($timebase - $timestamp) / $bucket_size);
            printf "%3d", $bucket < $bucket_count ? $bucket : "-";
            print " ", localtime($timestamp)->datetime, " ", $score, " ",
                $message, "\n";
        }
    }
} elsif ($opts{parse}) {
    log "debug", "parsing incoming bounce message for $listaddr";
    my $msg = Email::MIME->new(join "", <>);
    my $address = $opts{address} || "test\@example.com";

    my @parts = $msg->subparts;
    if (@parts == 2 && $parts[0]->body =~ m/^This just came in to /) {
        log "debug", "message presumed forwarded to owner, replacing with second part";
        $msg = Email::MIME->new($parts[1]->body);
    }

    log "debug", "parse: parser=$opts{parser}";
    my $parsers = [ split m/,/, $opts{parser} ];
    my (@bounces) = Lancelot::Module::process_bounce::classify($db, $msg,
                                                               $address,
                                                               $parsers);
    foreach my $b (@bounces) {
        my ($bounce_addr, $bounce_type) = @$b;
        print "$bounce_type\t$bounce_addr\n";
    }
}

exit 0;