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

=head1 NAME

mailman-pop3d - 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 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 web interface
to discard spam, this script may be for you.

mailman-pop3d 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 is quite useful for purging
large amounts of spam from a busy list's queue.

=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.2";

# 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", "pid", "daemon";
sub syslog { Sys::Syslog::syslog shift, join "", "[$ip] ", @_ } 

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

		welcome => "mailman-pop3d, 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 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;
				}

				if (($res->content =~ m!<TITLE>Mailman Admindb Error</TITLE>!i) or				# no such list
					($res->content =~ m!<TITLE>plug Administrative Authentication</TITLE>!i))	# invalid password
				{
					syslog "err", "Invalid username or password";
					return 0;
				}

				$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;