#!/usr/bin/perl -w

#
# unspamify_mailman.pl
# $xId:: unspamify_mailman.pl,v 1.16 2004/06/10 18:23:54 johnh Exp $
#
# Copyright (C) 2003 by John Heidemann <johnh@isi.edu>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License,
# version 2, as published by the Free Software Foundation.
# 
# 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, write to the Free Software Foundation, Inc.,
# 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
#



sub usage {
    print STDERR <<END;
usage: $0 [-mv] -p PASSWORD [URL]

Given a URL for a mailman mailing list and a PASSWORD to that list,
this program logs in to the list and discards all pending messages
(on the assumption that they are all spam).

Options:

-d	debug mode.  Do everything except discarding the messages.

-m	mail mode.  Read an e-mail message from stdin and find URL
	therein (where URL is whatever includes mailman and admindb)

-v	verbose.  Show what messages are dropped.

WARNING: If run with just a URL, this program blindly discards all
messages queued for the mailing list.  Instead, it is recommended you
run it with the -m option, in which case it will cancel mail for ONLY
those senders listed in the mail.

Brought to you by the virtues of WWW::Mechanize and screen-scraping.
"Oh what a tangled web we weave..."
END
    exit 1;
}

use strict;
use WWW::Mechanize;
use Getopt::Long;
use Carp;

&usage if ($#ARGV >= 0 && $ARGV[0] eq '-?');
my $debug = undef;
my $verbose = undef;
my $mailmode = undef;
my $password = undef;
GetOptions('d' => \$debug,
	    'm' => \$mailmode,
	    'p=s' => \$password,
	    'v+' => \$verbose);

if ($mailmode && $#ARGV < 0) {
    handle_mail("-");
};
foreach (@ARGV) {
    if ($mailmode) {
	handle_mail($_);
    } else {
	handle_url($_);
    };
};

exit 0;

sub assert_success {
    my($b) = @_;
    my $uri = $b->uri;  $uri = "(unknown)" if (!defined($uri)); 
    croak "$0: error on " . $uri . ": " . $b->response()->status_line . "\n"
	if (! $b->success());
}

sub handle_mail {
    my($filename) = @_;
    # simple validation
    die "$0: your filename $_ contains suspicious characters.  refusing to run.\n"
	if (($filename =~ /[^a-zA-Z0-9\/]/) && $filename ne '-');
    my(@urls, @senders);
    open(IN, "<$filename") || die "$0: cannot open $filename\n";
    my($past_pending_posts) = 0;
    while (<IN>) {
	push(@urls, $1)	if (m@^\s*(https?://.*mailman/admindb/\S+)\s*$@);
	$past_pending_posts = 1 if (/^(Pending posts:)/);
	$past_pending_posts = 2 if (/^(As list administrator, your authorization is requested for the)/);
	push(@senders, $1) if ($past_pending_posts && m@^From:\s+(\S+) on @);
	push(@senders, $1) if ($past_pending_posts == 2 && m@^\s+From:\s+(\S+)@);
    };
    close IN;
    print "found URLs: " . join("\n", @urls) . "\n" if ($verbose);
    print "found senders: " . join("\n", @senders) . "\n" if ($verbose);
    die "$0: no urls in message.\n"
	if ($#urls == -1);
    die "$0: too many urls in message.\n" . join("\n", @urls)
	if ($#urls != 0);
    foreach (@urls) {
	handle_url($_, \@senders);
    };
}

sub find_mm_version {
    my($text) = @_;
    foreach (split(/\n/, $text)) {
	if (m@mailman.jpg\" alt=\"Delivered by Mailman\".*version ([0-9.]+)</td>@) {
	    return $1;
	};
    };
    return "undetected";
}

sub handle_url {
    my($mailman_url, $senders_ref) = @_;

    # create a new browser
    my $b = WWW::Mechanize->new();

    #
    #  authenticate ourselves
    #
    $b->get($mailman_url);
    assert_success($b);

    $b->field('adminpw', $password);
#    $b->click("admlogin");
    $b->submit();
    assert_success($b);

    #
    # make sure we're on the right page
    #
    if ($b->response->content =~ /Authentication<\/title>/) {
	die "$0: internal error: confusion, content is still on authentication page--did you give the right password?\n";
    };
    if ($b->response->content !~ /<h2>Administrative requests for mailing list:/) {
	die "$0: internal error: confusion, not on admin request page.\n";
    };

    #
    # check the version
    #
    my($mm_version) = find_mm_version($b->response->content);
    my(%known_versions) = map { $_=>$_ } qw(2.1.1 2.1.4);
    if (!defined($known_versions{$mm_version})) {
	warn "warning: mailman version $mm_version not verified as accepted by $0.\n";
    };
    # print STDERR "mm version: $mm_version\n";

    #
    # check for already handled
    #
    if ($b->response->content =~ /h2.There are no pending requests\./) {
	die "$0: there are no pending requests.\n";
    };

    # prune by senders, if possible
    my(%bad_senders) = ();
    if (defined($senders_ref)) {
	%bad_senders = map { $_=>$_ } @$senders_ref;
    };

    #
    # extract the messages
    #
    my %actionids;
    my($last_sender) = '';
    my($last_sender_warned) = undef;
    foreach my $line (split(/\n/, $b->response->content)) {
	# next pattern checked against 2.1.4
	if ($line =~ m@\<center\>\<strong\>From:\</strong\>([^<]+)\</center\>@) {
	    $last_sender = $1;
	    $last_sender_warned = undef;
	};
	# this pattern matches 2.0.5, 2.1.1, 2.1.4
	if ($line =~ /input name=\"([^"]+)\"\s+type=\"radio\"\s+value=\"\d\"/i) { # "
	    my($key) = $1;
	    # discard senderfilter in 2.1.x and later
	    next if ($key =~ /^senderfilter-/);
	    # discard hit if it's not an approved sender and we're approving them
	    if (defined($senders_ref) && !defined($bad_senders{$last_sender})) {
		print "message skipped because its sender ($last_sender) wasn't known bad.\n" if ($verbose && !$last_sender_warned);
		$last_sender_warned = 1;
		next;
	    } else {
		# print "message killed because its sender ($last_sender) was known bad.\n";
	    };
	    # set the message up for deletion
	    if (defined($actionids{$key})) {
		$actionids{$key}++;
	    } else {
		$actionids{$key} = 1;
	    };
	    print "found $key in $line\n" if (defined($verbose) && $verbose > 1);
	};
    };

    #
    # sanity check: 
    # make sure we saw four of each senderaction
    #
    foreach (keys %actionids) {
	die "$0: confusion on $_.\n" if ($actionids{$_} != 4);
	# print "$_\n";
    };

    #
    # kill them (set to 3)
    # 0=defer, 1=accept, 2=reject, 3=discard
    #
    foreach (sort keys %actionids) {
        $b->field($_, 3);  # 3=discard
	print "discarding $_\n" if ($verbose);
    };
    if ($debug) {
	print "debugging mode, aborting.\n";
	exit 1;
    };
    $b->click("submit");
    assert_success($b);
}
    

exit 0;