path: root/contrib/mm-handler-2.1.10

#!/usr/bin/perl
##
## Sendmail mailer for Mailman
##
## Simulates these aliases:
##
##testlist:              "|/home/mailman/mail/mailman post testlist"
##testlist-admin:        "|/home/mailman/mail/mailman admin testlist"
##testlist-bounces:      "|/home/mailman/mail/mailman bounces testlist"
##testlist-confirm:      "|/home/mailman/mail/mailman confirm testlist"
##testlist-join:         "|/home/mailman/mail/mailman join testlist"
##testlist-leave:        "|/home/mailman/mail/mailman leave testlist"
##testlist-owner:        "|/home/mailman/mail/mailman owner testlist"
##testlist-request:      "|/home/mailman/mail/mailman request testlist"
##testlist-subscribe:    "|/home/mailman/mail/mailman subscribe testlist"
##testlist-unsubscribe:  "|/home/mailman/mail/mailman unsubscribe testlist"
##owner-testlist:        testlist-owner

#### Begin configuration here ####

$MMWRAPPER = "/usr/lib/mailman/mail/mailman";
$MMLISTDIR = "/var/lib/mailman/lists";
$SENDMAIL = "/usr/lib/sendmail -oem -oi";
$VERSION = '$Id: mm-handler 2.1.10 2008-04-14 00:00:00 $';

## Comment this if you offer local user addresses.
$NOUSERS = "\nPersonal e-mail addresses are not offered by this server.";

# set for debugging....
$DEBUG = 0;

# Define the set of actions you want to allow (that is, which aliases
# you want to emulate). This should be a subset of @ValidActions,
# defined below, plus the special "post" action.
#@ApprovedActions = qw(admin bounces confirm join leave
#                      owner request subscribe unsubscribe);
# aliases removed to suppress spam backscatter
@ApprovedActions = qw(bounces confirm owner request post);

# Allow backscatter for unapproved actions?
$BounceUnapproved = 0;

# Allow backscatter for undefined lists?
$BounceNonlist = 0;

#### End of configuration ####


use FileHandle;
use Sys::Hostname;
use Socket;
use Unix::Syslog qw(:macros);
use Unix::Syslog qw(:subs);
use File::Basename;

my $syslog_ident = basename $0;
my $syslog_options = LOG_PID;
my $syslog_facility = LOG_MAIL;

# These are the listname-action actions defined by the mailman wrapper
# program. Do not alter this unless a new Mailman version changes the
# set of supported actions.
@ValidActions = qw(admin bounces confirm join leave
                   owner request subscribe unsubscribe);

($VERS_STR = $VERSION) =~ s/^\$\S+\s+(\S+)(?:,v)?\s+(\S+\s+\S+\s+\S+).*/\1 \2/;

$BOUNDARY = sprintf("%08x-%d", time, time % $$);

## Informative, non-standard rejection letter
sub mail_error {
	my ($in, $to, $list, $server, $reason) = @_;
	my $sendmail;

	if ($server && $server ne "") {
		$servname = $server;
	} else {
		$servname = "This server";
		$server = &get_ip_addr;
	}

	#$sendmail = new FileHandle ">/tmp/mm-$$";
	$sendmail = new FileHandle "|$SENDMAIL $to";
	if (!defined($sendmail)) {
		syslog LOG_ERR, "cannot exec \"$SENDMAIL\"";
		exit (-1);
	}

	$sendmail->print ("From: MAILER-DAEMON\@$server
To: $to
Subject: Returned mail: List unknown
Mime-Version: 1.0
Content-type: multipart/mixed; boundary=\"$BOUNDARY\"
Content-Disposition: inline

--$BOUNDARY
Content-Type: text/plain; charset=us-ascii
Content-Description: Error processing your mail
Content-Disposition: inline

Your mail for $list could not be sent:
	$reason

For a list of publicly-advertised mailing lists hosted on this server,
visit this URL:
	http://$server/

If this does not resolve your problem, you may write to:
	postmaster\@$server
or
	mailman-owner\@$server


$servname delivers e-mail to registered mailing lists
and to the administrative addresses defined and required by IETF
Request for Comments (RFC) 2142 [1].
$NOUSERS

The Internet Engineering Task Force [2] (IETF) oversees the development
of open standards for the Internet community, including the protocols
and formats employed by Internet mail systems.

For your convenience, your original mail is attached.


[1] Crocker, D. \"Mailbox Names for Common Services, Roles and
    Functions\".  http://www.ietf.org/rfc/rfc2142.txt

[2] http://www.ietf.org/

--$BOUNDARY
Content-Type: message/rfc822
Content-Description: Your undelivered mail
Content-Disposition: attachment

");

	while ($_ = <$in>) {
		$sendmail->print ($_);
	}

	$sendmail->print ("\n");
	$sendmail->print ("--$BOUNDARY--\n");

	close($sendmail);
}

## Get my IP address, in case my sendmail doesn't tell me my name.
sub get_ip_addr {
	my $host = hostname;
	my $ip = gethostbyname($host);
	return inet_ntoa($ip);
}

## Split an address into its base list name and the appropriate command
## for the relevant function.
sub split_addr {
	my ($addr) = @_;
	my ($list, $cmd);

	if ($addr =~ /(.*)-([^-]+)\+.*$/) {
		$list = $1;
		$cmd = "$2";
	} elsif ($addr =~ /(.*)-([^-]+)$/) {
		$list = $1;
		$cmd = $2;
	}
	else {
		return ($addr, "post");
	}
	if ($list eq "owner") {
		# Allow owner-listname to work as listname-owner
		$list = $cmd;
		$cmd = "owner";
	} elsif (! grep /^$cmd$/, @ValidActions) {
		# If an undefined action, restore list name
		$list = $addr;
		$cmd = "post";
	}
	## Otherwise use $list and $cmd as already assigned

	return ($list, $cmd);
}

## Determine whether a list is defined in Mailman.
sub list_exists {
	my ($name) = @_;

	return 1 if (-f "$MMLISTDIR/$list/config.pck");
	return 1 if (-f "$MMLISTDIR/$list/config.db");
	return 0;
}

## The time, formatted as for an mbox's "From_" line.
sub mboxdate {
	my ($time) = @_;
	my @days = qw(Sun Mon Tue Wed Thu Fri Sat);
	my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
	my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
		localtime($time);

	## Two-digit year handling complies with RFC 2822 (section 4.3),
	## with the addition that three-digit years are accommodated.
	if ($year < 50) {
		$year += 2000;
	} elsif ($year < 1900) {
		$year += 1900;
	}

	return sprintf ("%s %s %2d %02d:%02d:%02d %d",
		$days[$wday], $months[$mon], $mday,
		$hour, $min, $sec, $year);
}

BEGIN: {
	openlog $syslog_ident, $syslog_options, $syslog_facility;
	$sender = undef;
	$server = undef;
	@to = ();
	while ($#ARGV >= 0) {
		if ($ARGV[0] eq "-r") {
			$sender = $ARGV[1];
			shift @ARGV;
		} elsif (!defined($server)) {
			$server = $ARGV[0];
		} else {
			push(@to, $ARGV[0]);
		}
		shift @ARGV;
	}

	if ($DEBUG) {
		my $to = join(',', @to);
		syslog LOG_INFO, "to: $to; sender: $sender; server: $server";
	}

ADDR:	for $addr (@to) {
		$prev = undef;
		$list = $addr;

		$was_to = $addr;
		$was_to .= "\@$server" if ("$server" ne "");

		$cmd= "post";
		($list, $cmd) = &split_addr($list);
		if ($DEBUG) {
			syslog LOG_INFO, "list: $list; cmd: $cmd";
		}
		if (! &list_exists($list)) {
			syslog LOG_INFO, "no list named \"$list\" is known by $server";
			if ($BounceNonlist) {
				mail_error(\*STDIN, $sender, $was_to, $server,
				           "no list named \"$list\" is known by $server");
			}
			next ADDR;
		}

		if (! grep /^$cmd$/, @ApprovedActions) {
			syslog LOG_INFO, "$cmd is not a recognized action for $list";
			if ($BounceUnapproved) {
				mail_error(\*STDIN, $sender, $was_to, $server,
					   "$cmd is not a recognized action for $list");
			}
			next ADDR;
		}

		if ($DEBUG) {
			syslog LOG_INFO, "invoking $MMWRAPPER";
		}
		$wrapper = new FileHandle "|$MMWRAPPER $cmd $list";
		if (!defined($wrapper)) {
			## Defer?
			syslog LOG_ERR, "cannot exec ",
				"\"$MMWRAPPER $cmd $list\": deferring";
			exit (-1);
		}

		# Don't need these without the "n" flag on the mailer def....
		#$date = &mboxdate(time);
		#$wrapper->print ("From $sender  $date\n");

		# ...because we use these instead.
		$from_ = <STDIN>;
		$wrapper->print ($from_);

		$wrapper->print ("X-Mailman-Handler: $VERSION\n");
		while (<STDIN>) {
			$wrapper->print ($_);
		}
		close($wrapper);
		if ($DEBUG) {
			syslog LOG_INFO, "message processed";
		}
	}
}