#!/usr/bin/perl
# vim:set ts=4 sw=4 ai:

=head1 NAME

mailman-pop3d.pl - POP3 interface to mailman's web interface

=cut

# This software should be considered to be in alpha stage; bugs are
# certainly present, and bug reports would be very much appreciated.
# At this point, I would also be very interested in hearing about
# success stories.  I've been testing only against mailman 2.0.11.
#
# 	-- Michael C. Toren <mct@toren.net>  Tue, 30 Mar 2004 20:11:06 -0500

use strict;
use warnings;

### Configurable section:
#
# What's the base URL for your mailman web interface?  The listname will be
# appended to this URL to access the administrative queue.
my $url = "http://lists.netisland.net/mailman/admindb/";
#
### End configurable section

=head1 DESCRIPTION

mailman-pop3d.pl provides a POP3 interface to mailman for the purposes
of deleting spam stuck in the administrative requests queue.  If you
manage a large mailman mailing list, and are tired of using the annoying
web interface to discard spam, this script may be for you.

mailman-pop3d.pl is typically invokved from /etc/inetd.conf, as:

	pop3 stream tcp nowait nobody.nogroup /usr/local/bin/mailman-pop3d.pl mailman-pop3d.pl

The POP3 interfaces accepts the name of a mailman list as the POP3
username, and the mailman administrative password as the POP3 password.
Once authenticated, a client is presented with a list of the messages
currently stuck in the mailman queue.  When messages are deleted from
the POP3 server, the corresponding message is discarded from the mailman
queue as spam.

=head1 BUGS

Currently there is no method of approving messages to be forwarded to
the list via the POP3 interface.  Even so, mailman-pop3d.pl is quite
useful for purging large amounts of spam from a busy list's queue.

If either an invalid POP3 username or password is supplied, no "invalid
login" error message is generated.  Instead, the only indication is that
no messages are presented to the client.

=head1 COPYRIGHT

(c) Copyright 2004 Michael C. Toren <mct@toren.net>

Portions of this program are based on Ry4an Brase's mailman-auto-reject.pl
script, which has been placed in the public domain, and is available from
<http://ry4an.org/unblog/msg00016.html>.

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.

A copy of the GNU GPL is available as /usr/share/common-licenses/GPL-2 on
Debian systems, or at <http://www.gnu.org/copyleft/gpl.html>.  You can also
obtain it by writing to the Free Software Foundation, Inc., 59 Temple Place
- Suite 330, Boston, MA 02111-1307, USA

=head1 AVAILABILITY

For updates, please see:

	http://michael.toren.net/code/

=cut

use Net::Server::POP3;
use HTTP::Request::Common qw(POST);
use HTTP::Cookies;
use HTML::Form;
use LWP::UserAgent;
use Sys::Syslog qw();
use Digest::MD5 qw(md5_hex);
use Socket;

my %actioncodes = (discard => 3, approve => 1, reject => 2, defer => 0);
my $debug = 0;

my ($version, $user, $pass, $ip, @msglist, $msgdata, $deleted,
	$ua, $jar, $req, $res, $form);

$version = "0.1";

# Net::Server::POP3 writes debugging information to STDERR, with no
# method to turn it off, which interferes with a servertype of INET.
open STDERR, "> /dev/null" unless (-t STDOUT);

Sys::Syslog::openlog "mailman-pop3d.pl", "pid", "daemon";
sub syslog { Sys::Syslog::syslog shift, join "", "[$ip] ", @_ } 

my $server = Net::Server::POP3->new
	(
		servertype => "INET",

		welcome => "mailman-pop3d.pl, version $version (http://michael.toren.net/code/)",

		"connect" => sub {
				if ($ip = getpeername STDIN) {
					$ip = inet_ntoa +(sockaddr_in $ip)[1];
				} else {
					$ip = "0.0.0.0"
				}

				syslog "debug", "connect";
			},

		authenticate => sub {
				($user, $pass) = @_;
				syslog "debug", "login for list $user";

				$url .= $user;
				$ua = LWP::UserAgent->new;
				$ua->agent("mailman-pop3d.pl version $version, ");
				$jar = HTTP::Cookies->new;

				$req = POST $url,
					[ request_login => "flooby", adminpw => $pass];
				$res = $ua->request($req);

				unless ($res->is_success)
				{
					syslog "err", "Error authenticating";
					return 0;
				}

				# XXX perform additional error checking to ensure the login
				#     attempt was successful

				$jar->extract_cookies($res);
				($form) = HTML::Form->parse($res->as_string, $res->base);
				return 1 unless ($form); # no messages waiting

				for my $input ($form->inputs)
				{
					my ($msg, $num, $id);

					unless ($input->type eq "radio")
					{
						syslog "debug", "Skipping input " . $input->name,
							", type ", $input->type if ($debug);
						next;
					}

					unless ($input->possible_values == 4)
					{
						syslog "debug", "Skipping input ", $input->name,
							" due to value count ",
								scalar($input->possible_values) if ($debug);
						next;
					}

					unless ($input->name =~ /^\d+$/)
					{
						syslog "debug", "Skipping input ", $input->name,
							" due non-numeric characters in it's name" if ($debug);
						next;
					}

					$num = $input->name;
					$msg->{form} = $input;
					$msg->{header} = $form->find_input("headers-$num", "textarea");
					$msg->{body} = $form->find_input("fulltext-$num", "textarea");

					unless ($msg->{header}) {
						syslog "err", "Header $num not found; skipping";
						next;
					}

					unless ($msg->{body}) {
						syslog "err", "Body $num not found; skipping";
						next;
					}

					$msg->{header} = $msg->{header}->value;
					$msg->{body} = $msg->{body}->value;
					$msg->{size} = length($msg->{header}) + length($msg->{body});

					$id = "$num." . md5_hex join "\n", $msg->{header}, $msg->{body};

					$msgdata->{$id} = $msg;
					push @msglist, $id;
				}

				return 1;
			},

		list => sub {
				syslog "debug", "list returning ", scalar(@msglist), " messages";
				return @msglist;
			},
		
		size => sub {
				my $id = shift;
				return $msgdata->{$id}->{size};
			},

		retrieve => sub {
				my $id = (@_)[1];
				syslog "debug", "retrieve $id" if ($debug);
				return join "\n", $msgdata->{$id}->{header},
									$msgdata->{$id}->{body},
									"";
			},

		"delete" => sub {
				my $id = (@_)[1];
				syslog "debug", "delete $id";
				$msgdata->{$id}->{form}->value($actioncodes{discard});
				$deleted++;
			},

		disconnect => sub {
				unless ($deleted) {
					syslog "debug", "disconnect, no messages deleted";
					return;
				} else {
					syslog "debug", "disconnect, deleting $deleted messages...";
				}

				$req = $form->click;
				$jar->add_cookie_header($req);
				$res = $ua->request($req);
				syslog "err", "Error handling requests"
					unless ($res->is_success);
				syslog "debug", "...disconnect complete";
			},
	);

$server->startserver;