#! /usr/local/bin/perl -w
#
# Extract the body of a mail message and treat each line in it as a
# regex for matching mailing lists on which to report.
#
use strict;
use DBD::mysql;
use DBI;
use Getopt::Long;
use Mail::Mailer;
use MIME::Parser;
use Text::Abbrev;
use Text::Shellwords;

my %options;
my $PROG;
my $msg = '';
my $batch = 0;
my $debug = 0;
my $mail2stdout = 0;

my $verbs = abbrev qw( debug
                       end
                       help
                       list
                       moderated-by
                     );

Getopt::Long::Configure('bundling');
Getopt::Long::Configure('auto_abbrev');
Getopt::Long::Configure('pass_through');
GetOptions(\%options,
           'batch|r'    => \$batch,
           'exec|e=s'   => \$PROG,
           'test|R'     => \$mail2stdout,
           'verbose|v+' => \$debug,
           );

my @patterns;
my $parser;
my $entity;
my $from;
my $abort = 0;

debug("Debug level=$debug");
#
# See if we're doing a command line, or reading from a mail message.
#
if (! $batch) {
    #
    # Mail message.  Trap any error text and include it in the output.
    #
    $SIG{__WARN__} = sub {
        $msg .= $_[0];
    };
    debug(4, 'Operating from email input');
    #
    # Okey, get the message.  If we can't, just die messily -- there's
    # no way to include anything in a reply.
    #
    $parser = new MIME::Parser;
    $parser->output_to_core(10000000);
    $parser->output_dir('/tmp/');
    eval {
        $parser->tmp_recycling(0);
    };
    $entity = $parser->read(\*STDIN) or do {
        print STDERR $msg;
        die("Couldn't get message from stdin!");
    };

    #
    # Get the sender (to whom the response will be sent), and the subject.
    #
    $from = ($entity->get('Reply-to')
             || $entity->get('From')
             || $entity->get('Sender'));
    $from =~ s§[\r\n\s]+]$§§g;
    $from = normalise_eddress($from);
    if ($from !~ /\@apache.org$/i) {
        $msg .= "Access restricted.\n\n"
            . "You are not authorised to access this information.\n";
        $abort = 1;
    }
    elsif ((my $nparts = $entity->parts()) > 1) {
        $msg .= "Cannot handle complex or multipart messages.  Please send\n"
            . "normal, unsigned, unencoded plaintext.  Your message\n"
            . "had $nparts parts/attachments.\n";
        $abort = 1;
    }
    else {
        #
        # Get the body.
        #
        my $body = $entity->bodyhandle()->as_string();
        @patterns = split(m§[\r\n]+§, $body);
    }
}
else {
    my $command_line = join(' ', @ARGV);
    debug(4, "Operating from command-line input: '$command_line'");
    @patterns = ($command_line);
}

#
# Ready to make the doughnuts..
#
debug('here we go');
if (! $abort) {
    if (@patterns) {
        for (@patterns) {
            debug(3, "Pattern input: '$_'");
        }
        $msg .= fetchdata(\@patterns);
    }
    else {
        $msg .= "\nNo command nor regex.\n";
        debug('No pattern input!');
    }
}

#
# Okey, time to issue our report.
#
if ($batch) {
    print $msg;
}
else {
    #
    # We received it via mail, so reply the same way.
    #
    my $subject = $entity->get('Subject');
    $subject =~ s§[\r\n\s]+]$§§g;
    $subject =~ s§^(?:(?:Re|Sv|Aw|Antwort):\s*)+§§gi;
    my $refs = $entity->get('References');
    my $msgid = $entity->get('Message-ID');

    my $reply = new Mail::Mailer('sendmail');
    my %header = ('Subject'        => "Re: $subject",
                  'To'             => $from,
                  'Bcc'            => 'Ken.Coar@Golux.Com',
                  'From'           => ('Apache Mailing List Info '
                                       . '<donotreply@Apache.Org>'),
                  'Content-Type'   => 'text/plain',
                  'MIME-Version'   => '1.0');
    if ($msgid) {
        chomp($refs) if ($refs);
        chomp($msgid) if ($msgid);
        $refs = $msgid . ($refs ? ", $refs" : '');
        $header{'In-Reply-To'} = $msgid;
        $header{'References'}  = $refs;
    }
    #
    # Are we actually returning the reply, or just testing?
    #
    if (! $mail2stdout) {
        $reply->open(\%header);
        print $reply $msg;
        $reply->close();
    }
    elsif ($debug) {
        print $msg;
    }
}
exit(0);

#
# Turn a possibly fancy eddress into the basic user@domain string.
#
sub normalise_eddress {
    my $email = shift;
    my @address_bits = Mail::Address->parse($email);
    my $envaddr = shift(@address_bits);
    $email = $envaddr->address();
    $email =~ s:\@(.*):\@\L$1\E:g;
    return $email;
}

sub debug {
    my $text = shift;
    my $level = 1;
    if ($text =~ /^\d+$/) {
        $level = $text;
        $text = shift;
    }
    if ($debug >= $level) {
        chomp($msg);
        chomp($text);
        $msg .= "\nDEBUG: $text\n";
    }
}

#
# Get the info from the database and build the reply.
#
sub fetchdata {
    my ($rpatterns) = @_;
    my @patterns = @{$rpatterns};
    my $msg = '';
    #
    # Now connect to the database.
    #
    debug(4, 'Connecting to the database');
    my $dsn = 'DBI:mysql:database=<dbname>:host=<dbfqhn>';
    my $dbx = DBI->connect($dsn, '<username>', '<password>',
                           {
                            RaiseError => 0,
                            PrintError => 0
                           });
    if (! $dbx) {
        debug(2, "Error connecting to the database");
    }
    #
    # Find out what the latest data import timestamp is.
    #
    debug(4, 'Determining date of most recent load');
    my $sql = ('SELECT asof FROM loadinfo '
               . 'ORDER BY asof DESC '
               . 'LIMIT 1 ');
    my $dbq = $dbx->prepare($sql);
    if (! $dbq->execute()) {
        debug(2, "Error fetching last load date");
    }
    my $loadinfo = $dbq->fetchrow_hashref();
    $dbq->finish();
    my $loaddate = $loadinfo->{asof};
    debug(4, "Last loaded at '$loaddate'");

    #
    # Start constructing the reply.
    #
    $msg .= 'Results of your quer'
        . (@patterns == 1 ? 'y' : 'ies')
        . " (based on information dated $loaddate):\n";

    #
    # Now loop through and try to turn each one into a command.
    #
    foreach my $pattern (@patterns) {
        debug(3, "Pattern loop: '$pattern'");
        $pattern =~ s/^\s+(.*)/$1/;
        next if (! $pattern);
        last if ($pattern =~ /^--\s$/i);
        $pattern =~ s/\s+$//;
        my @tokens = split(/\s+/, $pattern);
        my $verb = $tokens[0];
        #
        # Make a note of what we're going to try to parse as a command or RE.
        #
        $msg .= "\n[*] $pattern";
        my $isverb = $verbs->{lc($verb)};
        if (defined($isverb) && ($isverb eq 'debug')) {
            if ((@tokens > 1) && ($tokens[1] =~ /^\d+$/)) {
                $debug = $tokens[1];
            }
            else {
                $debug++;
            }
            debug("Debug level now $debug");
            next;
        }
        debug(2, "DSN=$dsn");
        my @words = shellwords($pattern);
        debug('Shellwords => ("' . join('","', @words) . '")');
        my $field = undef;
        #
        # The command parser operates on @ARGV, so save a copy and
        # replace it with our own command.  Actually, a null command;
        # turn the verb into a parsable option by prefixing it with '-'.
        #
        my @argv_temp = @ARGV;
        @ARGV = @words;
        if (defined($isverb)) {
            $ARGV[0] = $isverb;
        }
        last if (defined($isverb) && ($isverb eq 'end'));
        $ARGV[0] = '--' . $ARGV[0];
        GetOptions('list'         => sub { $field = 'list'; },
                   'moderated-by' => sub { $field = 'moderators'; },
                   'help'         => sub { $field = 'help'; });
        #
        # If the first word was recognisably one of our verbs, take
        # any leftover string as the expressions to use.
        #
        if ($field || defined($isverb)) {
            @words = @ARGV;
        }
        else {
            #
            # Anything that isn't one of our verbs we treat as a regex for
            # an implicit 'list' verb.
            #
            $field = 'list';
        }
        debug(2, '@words = "' . join('" "', @words) . '"');
        if (defined($isverb) && ($isverb eq 'help')) {
            $msg .= helpout(@words);
            next;
        }
        #
        # We're actually only interested in the first word.  For now.
        # Stick the actual script command line arguments back where they
        # belong.
        #
        $pattern = $words[0];
        @ARGV = @argv_temp;
#        $pattern =~ s/^\s*(.*)?\s*/$1/g if ($pattern !~ /^\s*$/);
        #
        # We now have a regex and a field name.  Ask the database about
        # them.
        #
        $sql = ('SELECT DISTINCT list FROM list '
                . "WHERE ($field REGEXP '$pattern') "
                . "AND (asof = '$loaddate') "
                . 'ORDER BY domain ASC, list ASC ');
        debug(5, 'Using SQL: ' . $sql);
        $dbq = $dbx->prepare($sql);
        $dbq->execute();
        my $lists = $dbq->fetchall_arrayref();
        $dbq->finish();
        $msg .= "\nLists with $field matching '$pattern'";
        if ((! $lists) || (! @{$lists})) {
            debug(4, 'No matching lists');
            $msg .= ":\n  None.\n";
        }
        else {
            $msg .= ' (' . scalar(@{$lists}) . "):\n";
            #
            # Okey, one or more lists actually matched.  Report on all
            # matches.  First, collect all the list names together so
            # we can loop through them.
            #
            debug(4, scalar(@{$lists}) . ' matching lists');
            my @listname;
            for (@{$lists}) {
                push(@listname, $_->[0]);
            }
            #
            # Now get the particulars.
            #
            foreach my $listname (@listname) {
                $sql = ('SELECT * FROM list '
                        . "WHERE (list = '$listname') "
                        . "AND (asof = '$loaddate') ");
                $dbq = $dbx->prepare($sql);
                $dbq->execute();
                my $listinfo = $dbq->fetchrow_hashref();
                $dbq->finish();
                my $n = $listinfo->{count};
                my $dn = $listinfo->{dcount} || 0;
                my $mods = $listinfo->{moderators};
                $mods =~ s/,/, /g;
                $msg .= "  $listname\n"
                    . "    Subscribers:    $n\n"
                    . '    Digest readers: '
                    . ($dn < 0 ? 'no digest' : $dn) . "\n"
                    . "    Moderators:     $mods\n"
                    . "\n";
            }
        }
    }
    #
    # Gone through 'em all; let us leave this place.
    #
    $dbx->disconnect();
    return $msg;
}

sub helpout {
    my (@words) = @_;
    my $msg = '';
    debug(4, 'helpout(<' . join('>,<', @words) . '>)');
    if (@words > 0) {
        my $isverb = $verbs->{lc($words[0])};
        if ($isverb eq 'moderated-by') {
            $msg .= "\nHELP MODERATED-BY\n"
                . "\n  moderated-by [regex]\n"
                . "\n  The first argument is treated as a regular "
                . "expression, and"
                . "\n  all lists which have at least one moderator "
                . "whose eddress matches"
                . "\n  the pattern will be included.\n";
        }
        elsif ($isverb eq 'debug') {
            $msg .= "\nHELP DEBUG\n"
                . "\n  debug\n"
                . "\n  Increments the debug level each time it's"
                . "\n  encountered.  Deep Magic, don't mess with it.\n";
        }
        elsif ($isverb eq 'list') {
            $msg .= "\nHELP LIST\n"
                . "\n  list [regex]\n"
                . "\n  The first argument is treated as a regular "
                . "expression, and"
                . "\n  all lists with names that match the pattern "
                . "the pattern will be included.\n"
                . "\n  Note that you may omit the 'list' verb and "
                . "just specify a regular expression.\n";
        }
        elsif ($isverb eq 'help') {
            $msg .= "\nHELP HELP\n"
                . "\n  You're kidding, right?\n";
        }
        elsif ($isverb eq 'end') {
            $msg .= "\nHELP END\n"
                . "\n  end\n"
                . "\n  This command signals the end of the commands"
                . "\n  in the message.  All text after this will be"
                . "\n  ignored.\n";
        }
    }
    else {
        $msg .= "\nHelp for this utility:\n"
            . "\nSend a message to the query address with one or"
            . "\nmore of the following:\n"
            . "\n help"
            . "\n    this message\n"
            . "\n moderated-by [eddress-pattern]"
            . "\n    info about all lists with matching moderators\n"
            . "\n [list] list-pattern"
            . "\n    info about all matching lists\n"
            . "\n end"
            . "\n    End parsing of the message as commands.  Text"
            . "\n    appearing after this verb is ignored.\n"
            . "\nAnything that doesn't begin with one of these"
            . "\nkeywords (or an abbreviation thereof) will be"
            . "\ntreated as a Perl regex -- as though 'list' was"
            . "\nthe command.\n";
    }
    return $msg;
}
#
# Local Variables:
# mode: cperl
# tab-width: 4
# indent-tabs-mode: nil
# End:
#
