#!/usr/bin/perl -w
###############################################################################
# Purpose: automatically handles mailman administrative requests 
# Usage:   run the script with --help option
# Authors:  Vadim Zeitlin <vadim@wxwindows.org>
#           Daniel Veillard <daniel@veillard.com>
# License: BSD (http://opensource.org/licenses/bsd-license.php)
# Created: 04.04.04
# Version: 0.03 alpha
# RCS-Id:  $Id$
###############################################################################

# TODO:
#   - automatically analyze the "reason" and act accordingly?
#
# 0.03:
# read $HOME/.bounces for informations, add default filtering option
# where messages are discarded based on preferences
#

use strict;

use Getopt::Long ();
use HTML::Entities ();
use HTML::HeadParser ();
use HTML::TokeParser ();
use HTTP::Request::Common qw(GET POST);
use HTTP::Cookies ();
use LWP::UserAgent ();
use LWP::Simple ();

# uncomment this for tons of debugging messages
#use LWP::Debug qw(+);


###############################################################################
# Subroutines
###############################################################################

sub ProcessMessages();
sub ListMessages();
sub FilterMessages();

# return the URL we're redirected to
sub GetRedirectUrl($) {
    my $response = $_[0];

    my $url = $response->header('Location') || return undef;

    # the Location URL is sometimes non-absolute which is not allowed, fix it
    local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
    my $base = $response->base;
    $url = $HTTP::URI_CLASS->new($url, $base)->abs($base);

    return $url;
}
# go to the given tag, die if not found
#
# parameters: HTML::TokeParser object, the tag to go to
# returns: the array reference returned by (successful) get_tag()
sub GoToTag($$) {
    my ($htmlParser, $tag) = @_;

    my $token = $htmlParser->get_tag($tag);
    if ( !$token ) {
        die "No <$tag> tag found.\n";
    }

    return $token;
}

# extract the list of the messages being held for approval from the mailman
# administrative tasks HTML page
#
# parameters: the full HTML text of the page
# returns: array of (msgno, from, subject, reason) arrays
sub GetListOfHeldMessages($) {
    my $html = $_[0];

    # look whether we have any messages to approve
    my $marker = "Posting Held for Approval";
    my $pos = index $html, $marker;
    if ( $pos == -1 ) {
        # no messages at all
        return;
    }

    # and how many of them do we have?
    my $count;
    if ( substr($html, $pos + length $marker, 30) =~ /^ \(1 of (\d+)\)/ ) {
        $count = $1;
    }
    else {
        # mailman omits "1 of N" if there is only one message
        $count = 1;
    }

    # now extract the information about all messages
    my @msgs = ();
    my $htmlParser = HTML::TokeParser->new(\$html);

    # locate the beginning of the form
    GoToTag($htmlParser, "form");

    # extract the message details: they're given in the first 3 table rows
    for ( 1..$count ) { 
        GoToTag($htmlParser, "table");
        GoToTag($htmlParser, "td");
        GoToTag($htmlParser, "td");
        my $from = $htmlParser->get_text("/td");

        GoToTag($htmlParser, "td");
        GoToTag($htmlParser, "td");
        my $subject = $htmlParser->get_text("/td");

        GoToTag($htmlParser, "td");
        GoToTag($htmlParser, "td");
        my $reason = $htmlParser->get_text("/td");

        # the number of the message
        my $number = GoToTag($htmlParser, "input")->[1]{'name'};

        GoToTag($htmlParser, "textarea");
        GoToTag($htmlParser, "textarea");
        my $headers = $htmlParser->get_text("/textarea");
        GoToTag($htmlParser, "textarea");
        my $content = $htmlParser->get_text("/textarea");
# TODO extend with more informations
        push @msgs, [$number, $from, $subject, $reason, $headers, $content];
    }

    return @msgs;
}

###############################################################################
# Main program
###############################################################################

# command line options parsing
###############################################################################

my $VERSION_STRING = "0.02";

# boolean: if true, suppress messages
my $quiet = 0;

# resume from the last message retrieved?
my $resume = 1;

# the base admindb URL
my $baseurl;

# the list of messages to operate on
my @messages;

# the command to perform
my $command;

# the admin password
my $password;

# file to store cookies in
my $cookie_file = '';

# the proxy to use
my $proxy = "";

# booleans: version/help requested from cmd line?
my $version = 0;
my $help = 0;

my $usage = <<EOF
$0 [options] <admindb_url> [<command> [message[, message...]]]

where command is one of: list (default), accept, discard
and is applied to the messages with the specified numbers (or all by
default) held for approval at the given mailman URL.

--help          give the usage message showing the program options
--version       show the program version and exit
--verbose       give verbose informational messages (default)
--quiet         be silent, only error messages are given
--pass=pass     the mailing list administrative password
--cookies=xxx   file to use to store cookies in
--proxy=url     use the given proxy, if 'no' don't use proxy at all (even not
                the environment variable http_proxy which is used by default)
EOF
;

# main program start
###############################################################################

# don't forget to modify the usage section above if you add more options!
Getopt::Long::GetOptions
(
    'verbose'       => sub { $quiet = 0 },
    'quiet'         => \$quiet,
    'version'       => \$version,
    'help'          => \$help,
    'pass=s'        => \$password,
    'cookies=s'     => \$cookie_file,
    'proxy=s'       => \$proxy,
    '<>'            => sub {
                        if ( $baseurl ) {
                            if ( $command ) {
                                push @messages, split(/,/, $_[0])
                            }
                            else {
                                $command = lc $_[0]
                            }
                        }
                        else {
                            $baseurl = $_[0]
                        }
                       }
) || die $usage;

if ( $version || $help ) {
    if ( $version ) {
        print "mladmin version $VERSION_STRING, " .
              "written by Vadim Zeitlin <vadim\@wxwindows.org>\n";
    }
    else {
        print $usage;
    }

    exit 0;
}

#
# read the configuration options from the config file if any
#
my $conffile=$ENV{'HOME'}."/.bounces";

#
# Open the configuration file and fills the %lists, %pass arrays
# and reads the exclude patterns for @from, @subject, @header, @content
#
my %lists;
my %pass;
my @lists = ();
my @pass = ();
my @from = ();
my @reason = ();
my @subject = ();
my @header = ();
my @content = ();
open(CONFIG, $conffile);
while (<CONFIG>) {
    chomp;
    if ( $_ =~ /^#/ ) {
    } elsif ( $_ =~ /^\s*$/ ) {
    } elsif ( $_ =~ /^list/ ) {
        my ($tok, $name, $url, $passwd) = split(/\s+/, $_);
        $lists{$name} = $url;
        $pass{$name} = $passwd;
        print "Parsed informations for list $name\n"
    } elsif ( $_ =~ /^reject/ ) {
        my $value = $_;
        $value =~ s/^reject\s+(.*)/$1/;
        my $key = $value;
        $key =~ s/^(\w+)\s+.*/$1/;
        $value =~ s/^\w+\s+(.*)/$1/;
        if ( $key =~ 'from' ) {
            push @from, $value;
        } elsif ( $key =~ 'subject' ) {
            push @subject, $value;
        } elsif ( $key =~ 'header' ) {
            push @header, $value;
        } elsif ( $key =~ 'content' ) {
            push @content, $value;
        } elsif ( $key =~ 'reason' ) {
            push @reason, $value;
        } else {
            print "Unknown key $key value $value\n";
        }
    } else {
        print "ignored $_\n";
    }
}
close(CONFIG);

my $nb_list = keys(%lists);
if ( $nb_list != 0 ) {
    print "Read options for $nb_list lists\n";
}

#
# check we have enouth parameters
#
if ( !$baseurl and $nb_list == 0 ) {
    die "Required argument \"admindb_url\" is missing.\n$usage"
}

$command = "" if !defined $command;
if ( $command ne "" &&
        $command ne "list" &&
            $command ne "discard" &&
                $command ne "accept" &&
                    $command ne "filter") {
    die "Unknown command \"$command\": only \"list\", \"accept\" " .
        ", \"discard\" or \"filter\" allowed.\n" . "$usage"
}

my $ua;
my $count;
my @msgs;
my $list;

if ($nb_list == 0 ) {
    &process_list($baseurl, $password);
} else {
    my $url;
    my $name;
    my $pw;

    if ($command eq "") {
        $command = "filter";
    }
    while (($name,$url) = each %lists) {
        $pw = $pass{$name};
        &process_list($url, $pw);
    }
}

#
# Main subroutine to process a given list
# arguments are the baseurl and the password
#
sub process_list {
    my $request;
    my $response;

    $baseurl = $_[0];
    $password = $_[1];

    # the short list name
    $list = $baseurl;
    $list =~ s@^.*admindb/@@;
    
    # we need to "login" to the service first: for this we need to get the cookie
    # which is set by the page we are redirected to when we initially try to
    # access the archive
    $ua = LWP::UserAgent->new;
    $ua->agent("mladmin/$VERSION_STRING");
    if ( $proxy ) {
        $ua->proxy('http', $proxy);
    }
    elsif ( $proxy ne 'no' ) {
        # use http_proxy env var if set
        $ua->env_proxy();
    }
    #else: don't use proxy at all
    
    # determine what to do with cookies
    my $cookie_jar;
    if ( $cookie_file ) {
        # store them
        $cookie_jar = HTTP::Cookies->new(file => $cookie_file,
                                         autosave => 1,
                                         ignore_discard => 1);
    }
    else {
        # don't store, use just during this session
        $cookie_jar = HTTP::Cookies->new();
    }
    $ua->cookie_jar($cookie_jar);
    
    # unbuffer stdout as we want the progress messages to appear immediately
    select((select(STDOUT), $| = 1)[0]);
    
    # try to get the list of admin tasks directly if we use an existing cookies
    # file (otherwise wecan be sure that we need to login first)
    my $html;   # the text of the admindb main page
    my $login;  # do we need to login?
    if ( $cookie_file ) {
        $request = GET $baseurl;
        $response = $ua->simple_request($request);
        if ( !$response->is_success ) {
            die "Failed to retrieve the list of administrative tasks.\n"
        }
    
        $html = $response->content;
        $login = $html =~ "Administrative Authentication";
    }
    else {
        $login = 1;
    }
    
    if ( $login ) {
        if ( !$password ) {
            my $hasReadKey = eval { require Term::ReadKey; };
            if ( !$hasReadKey ) {
                warn "Please install Term::ReadKey to avoid echoing the password!\n";
            }
    
            print "Administrative password for $list: ";
    
            if ( $hasReadKey ) {
                Term::ReadKey::ReadMode('noecho');
                $password = Term::ReadKey::ReadLine(0); # 0 means normal read
                Term::ReadKey::ReadMode('restore');
            }
            else {
                $password = <STDIN>
            }
    
            chomp $password;
    
            print "\n";
        }
    
        print "Logging in to $list... " unless $quiet;
    
        $request = POST $baseurl, [ "adminpw" => $password ];
        $response = $ua->simple_request($request);
    
        # although simple_request() adds the cookies for us we should
        # extract them from the response we get manually
        $cookie_jar->extract_cookies($response);
    
        while ( $response->is_redirect ) {
            my $url = GetRedirectUrl($response);
    
            # go to the new page
            if ( $url ) {
                $request = GET $url;
                $response = $ua->simple_request($request);
            }
        }
    
        if ( !$response->is_success ) {
            print "Failed!\n";
            exit 2
        }
    
        if ( $response->content =~ "Authentication failed" ) {
            print "wrong password\n";
            exit 3
        }
    
        print "ok.\n";
    
        $html = $response->content;
    }
    #else: already authentificated
    
    # get the list of all postings held for approval
    @msgs = GetListOfHeldMessages($html);
    $count = $#msgs + 1;
    if ( !$count ) {
        warn "No held messages for the list $list.\n";
    }
    # process the command given to us
    elsif ( $command eq "" || $command eq "list" ) {
        ListMessages
    }
    elsif ( $command eq "filter" ) {
        FilterMessages
    }
    else { # command == "discard" or "accept"
        ProcessMessages
    }
    
}
exit 0;

###############################################################################
# More subroutines
###############################################################################

# discard or accept the messages
sub ProcessMessages() {
    my $all = $#messages == -1;
    print "Preparing to $command " . ($all ? "all " : "") . "messages " .
          ($all ? "" : join(',', @messages)) . "... " unless $quiet;

    # build the POST arguments string
    my %args;

    # the radiobox command index
    my $cmd = $command eq "discard" ? "3" : "1";

    for ( $all ? 0..$#msgs : map(--$_, @messages) ) {
        $args{@{$msgs[$_]}[0]} = $cmd
    }

    my $request = POST $baseurl, \%args;
    my $response = $ua->simple_request($request);
    if ( !$response->is_success ) {
        warn "failed!\n";
    }
    else {
        $count = ($all ? $#msgs : $#messages) + 1;
        my $sfx = $count == 1 ? "" : "s";
        printf "$count message$sfx ${command}ed.\n" unless $quiet;
    }
}

# list the messages and optionally propose to discard them
sub ListMessages() {
    # get the terminal size: use Term::Size if installed, fall back to
    # environment otherwise
    my $COLUMNS = 0;
    if ( eval { require Term::Size; } ) {
        $COLUMNS = &Term::Size::chars
    }

    $COLUMNS ||= $ENV{"COLUMNS"} || 80;

    print "$count message" . ($count == 1 ? "" : "s") .
          " held for approval for the list $list:\n" .
          "\n";

    my ($widthFrom, $widthSubj, $widthReason) =
        ($COLUMNS / 3, $COLUMNS / 3, $COLUMNS - 2*($COLUMNS / 3) - 5);

    my $fmt = sprintf "%%-%d.%ds%%-%d.%ds%%-%d.%ds\n",
                      $widthFrom + 1, $widthFrom,
                      $widthSubj + 1, $widthSubj,
                      $widthReason, $widthReason;

    printf " N " . $fmt,
           "From", "Subject", "Reason";

    print '-' x $COLUMNS . "\n";
          
    for (0..$#msgs) {
        my @msg = @{$msgs[$_]};
        printf "%2d " . $fmt,
               $_ + 1, $msg[1], $msg[2], $msg[3]
    }

    print '-' x $COLUMNS . "\n";

    # don't propose to discard messages if "--list" was explicitly specified
    if ( $command eq "" ) {
        print "Discard all messages (y/[n])? ";
        if ( <> =~ /^y/i ) {
            $command = "discard";
            ProcessMessages
        }
        else {
            print "Nothing done.\n" unless $quiet
        }
    }
}

# Filter the messages, discarding the unwanted ones
sub FilterMessages() {
    # build the POST arguments string
    my %args;
    my $req;
    my $res;
    my $discard_nr = 0;

    # the radiobox command index
    my $cmd = "3";


    print "$count message" . ($count == 1 ? "" : "s") .
          " held for approval for the list $list:\n" .
          "\n";

    for (0..$#msgs) {
        my @msg = @{$msgs[$_]};
        my $frm = $msg[1];
        my $sub = $msg[2];
        my $rea = $msg[3];
        my $head = $msg[4];
        my $cont = $msg[5];
        my $discard = 0;
        my $nr = $_;

        for (0..scalar(@from) - 1) {
            if ($discard == 1) {
            } elsif ( $frm =~ /$from[$_]/i ) {
                print "From: $frm\n";
                print "Subject: $sub\n";
                print "From $frm matches $from[$_] : discard it\n";
                $discard = 1;
            }
        }
        if ($discard == 0) {
            for (0..scalar(@subject) - 1) {
                if ($discard == 1) {
                } elsif ( $sub =~ /$subject[$_]/i ) {
                    print "From: $frm\n";
                    print "Subject: $sub\n";
                    print "Subject $sub matches $subject[$_] : discard it\n";
                    $discard = 1;
                }
            }
        }
        if ($discard == 0) {
            for (0..scalar(@reason) - 1) {
                if ($discard == 1) {
                } elsif ( $rea =~ /$reason[$_]/i ) {
                    print "From: $frm\n";
                    print "Subject: $sub\n";
                    print "Reason $rea matches $reason[$_] : discard it\n";
                    $discard = 1;
                }
            }
        }
        if ($discard == 0) {
            for (0..scalar(@header) - 1) {
                if ($discard == 1) {
                } elsif ( $head =~ /$header[$_]/i ) {
                    print "From: $frm\n";
                    print "Subject: $sub\n";
                    print "Headers matches $reason[$_] : discard it\n";
                    $discard = 1;
                }
            }
        }
        if ($discard == 0) {
            for (0..scalar(@content) - 1) {
                if ($discard == 1) {
                } elsif ( $cont =~ /$content[$_]/i ) {
                    print "From: $frm\n";
                    print "Subject: $sub\n";
                    print "Content matches $content[$_] : discard it\n";
                    $discard = 1;
                }
            }
        }
        if ( $discard == 1 ) {
            $args{@{$msgs[$nr]}[0]} = $cmd;
            $discard_nr = $discard_nr + 1;
        } else {
            $args{@{$msgs[$nr]}[0]} = "0";
        }
    }
    if ( $discard_nr != 0) {
        print "Discarding $discard_nr messages out of $count\n";
        $req = POST $baseurl, \%args;
        $res = $ua->simple_request($req);
        if ( !$res->is_success ) {
            warn "failed!\n";
        }
        else {
            printf "success\n";
        }
    }
}

# History:
#
# 0.03:
#       ask whether to delete all messages
#       better support for terminals with width != 80
#
# 0.02:
#       added "messages" argument and accept command
#
# 0.01:
#       initial barely functional release

# vi: set ts=4 sw=4 et cin: