#!/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

## Some assembly required.
my $MMWRAPPER = "/usr/local/mailman/mail/mailman";
my $MMLISTDIR = "/usr/local/mailman/lists";
my $SEND_MAIL = "/usr/lib/sendmail";
my $VERSION = '$Id: mm-handler 5100 2007-07-08 03:14:09Z $';
## Comment this if you offer local user addresses.
my $NOUSERS = "\nPersonal e-mail addresses are not offered by this server.";
my $SENDMAIL = "$SEND_MAIL -oem -oi";

use FileHandle 2.01;
use Sys::Hostname 1.11;
use Socket 1.77;
use Sys::Syslog 0.08 qw(:DEFAULT setlogsock);
use File::Basename 2.73;
use Getopt::Long 2.34;
use POSIX 1.08;
use strict 1.03;

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

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

my $user = getpwuid(geteuid());
my $group = getgrgid(getegid());
setlogsock('unix');
my($progname, $directory) = fileparse($0);
openlog($progname,"pid","mail");
syslog('debug', "running as $user:$group");
if($user eq 'root') {
        syslog('warning', "running as root. For security reasons you should configure sendmail.mc to run the mailer as non-root");
}
my $err_status = 0;

if(!-f $MMWRAPPER) {
        syslog('err', "can not find $MMWRAPPER.  Please configure");
        $err_status = 1;
}
if(!-d $MMLISTDIR) {
        syslog('err', "can not find $MMLISTDIR.  Please configure");
        $err_status = 1;
}
if(!-f $SEND_MAIL) {
        syslog('err', "can not find $SEND_MAIL. Please configure");
        $err_status = 1;
}

if($err_status) {exit(-1)};

my $base = undef;

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

        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('err', "$base [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:
        https://$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);
        my @validfields = qw(admin bounces confirm join leave owner request
                                subscribe unsubscribe);

        if ($addr =~ /(.*)-(.*)\+.*$/) {
                $list = $1;
                $cmd = "$2";
        } else {
                $addr =~ /(.*)-(.*)$/;
                $list = $1;
                $cmd = $2;
        }
        if (grep /^$cmd$/, @validfields) {
                if ($list eq "owner") {
                        $list = $cmd;
                        $cmd = "owner";
                }
        } else {
                $list = $addr;
                $cmd = "post";
        }

        return ($list, $cmd);
}

## 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: {
        my $sender = undef;
        my $server = undef;
        my @to = ();
        syslog('debug', "arguments: @ARGV");
        if($#ARGV < 0) {
                syslog('debug', "No arguments passed, doing nothing");
                exit(0);
        }
        GetOptions("r:s" => \$sender,
                   "j:s" => \$server,
                   "d:s" => \@to);
        $base = "to: @to sender:$sender server: $server";
        syslog('info',"$base [info]");

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

print $list;
                my $cmd= "post";
                if (! -f "$MMLISTDIR/$list/config.pck") {
                        ($list, $cmd) = &split_addr($list);
                        if (! -f "$MMLISTDIR/$list/config.pck") {
                                my $was_to = $addr;
                                $was_to .= "\@$server" if ("$server" ne "");
                                syslog("err", "$base [no list named $list]");
                                mail_error(\*STDIN, $sender, $was_to, $server,
                                        "no list named \"$list\" is known by $server");
                                next ADDR;
                        }
                }

                my $wrapper = new FileHandle "|$MMWRAPPER $cmd $list";
                if (!defined($wrapper)) {
                        ## Defer?
                        syslog('err', "$base [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.
                my $from_ = <STDIN>;
                $wrapper->print ($from_);

                $wrapper->print ("X-Mailman-Handler: $VERSION\n");
                while (<STDIN>) {
                        $wrapper->print ($_);
                }
                close($wrapper);
        }
}
END {
        closelog();
}