root/bin/pl-incoming

#!/usr/bin/perl -w

=head1 NAME

pl-incoming - process incoming messages on a Lancelot list

=head1 SYNOPSIS

pl-incoming [-dv?] [--user=USER] list@domain

=head1 DESCRIPTION

When a Lancelot list is installed, the local mail server must be directed
to forward all messages that arrive on the list address to B<pl-incoming>,
e.g., by setting up suitable aliases. The B<pl-incoming> program parses
the incoming message and launches an appropriate workflow, for example
to post a message to all subscribers, or to handle a subscription or
unsubscription request.

B<pl-incoming> reads a message from standard input and considers its
"To:" address. For a list called I<list>@I<domain>, several
possibilities exist:

  I<list>@I<domain>
  I<list>-help@I<domain>
  I<list>-owner@I<domain>
  I<list>-subscribe@I<domain>
  I<list>-subscribe-I<address>@I<domain>
  I<list>-unsubscribe@I<domain>
  I<list>-unsubscribe-I<address>@I<domain>
  I<list>-config@I<domain>
  I<list>-confirm-I<cookie>@I<domain>
  I<list>-bounce-I<address>-I<message>@I<domain>

(not all of which are currently implemented). The first word after I<list>
(or "submit" for I<list>@I<domain>) identifies a "workflow" to be used
for processing the message. Workflows are defined by the list owner and
(usually) stored in the list's configuration database, and consist of a
number of successive steps to be taken with the message.

Normally B<pl-incoming> searches for the list's configuration within the
home directory of the user running it. The B<--user> option specifies
a different user whose home directory is to be considered instead. Note that
the directories and files in question must be searchable/readable by the
user running B<pl-incoming>; the option does not arrange for any rights to
be available to that user that they would not otherwise have. The idea behind
this option is to be able to refer to individual users' mailing lists from
system-wide aliases files.

=head1 SEE ALSO

pl-conf(1), pl-init(1)

=head1 AUTHOR

Anselm Lingnau <anselm@anselms.net>

=head1 COPYRIGHT AND LICENSE

Copyright 2004 by Anselm Lingnau. This program is free software; you
may redistribute it and/or modify it under the terms of the GNU
General Public License as published by the Free Software Foundation;
either version 2 of the License, or (at your option) any later version.

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, refer to
<URL:http://www.gnu.org/copyleft/gpl.html>. You may also obtain it by
writing to the Free Software Foundation, Inc., 59 Temple Place - Suite
330, Boston, MA 02111-1307, USA.

=cut

use strict;

# Make Binary find it's libraries for non standard installations ...
use Config;
use File::Basename;
use vars qw($g_base_dir);
BEGIN {
    use FindBin qw($Bin);
    $g_base_dir = dirname ($Bin);
}
use lib "$g_base_dir/lib";
use lib "$g_base_dir/lib/perl5/$Config{version}";
use lib "$g_base_dir/lib/perl5/site_perl/$Config{version}";

use Lancelot::GetOpt qw/GetOptions/;

use Lancelot::Message;
use Lancelot::DB;
use Lancelot::Workflow;
use Lancelot::Send;

use Lancelot::Log qw/log log_and_die/;

use File::Spec;
use Email::Address;

my ($EX_TEMPFAIL) = 75;

my (%opts);

GetOptions(\%opts, -argvmin => 1, "no list address specified",
                   -argvmax => 1, "too many arguments",
                   "user|u=");

my ($listaddr) = shift;

# Read the message from standard input, and quit if it is one that we
# have processed before.

my ($msg) = new Lancelot::Message join "", <STDIN>;
my $loop;
exit 0 if defined ($loop = $msg->header("X-Loop")) && $loop =~ /^$listaddr:/i;

my $db = new Lancelot::DB $listaddr, { user => $opts{user}, nodefault => 1 }
           or die "couldn't find mailing list $listaddr\n";

if (-f File::Spec->join($db->get_listdir(), "no-forward")) {
    return $EX_TEMPFAIL;
}

if (my $tracefile = $db->get_config("mail.trace")) {
    my $f = IO::File->new(">> $tracefile");
    print $f "-" x 72, "\n";
    print $f "Time: ", scalar(localtime), "\n";
    print $f "-" x 72, "\n";
    print $f $msg->as_string;
    $f->close;
}

# Find the workflow name and possible arguments (such as an auxiliary
# address for a subscription or VERP parameters on a bounce)

my ($wfname) = parse_to($listaddr, $msg);
$wfname = "help" if !$wfname || $wfname !~ /^[A-Za-z]\w*$/;

my ($wf) = new Lancelot::Workflow "mail.workflow", $wfname,
                                  $db, $msg, \&bounce;
my ($ret) = $wf->execute;
$ret = $EX_TEMPFAIL if $ret == 1;

exit $ret;

# parse_to - Parse the message's (SMTP) »To« address to find the workflow
#            and arguments

sub parse_to {
    my ($listaddr, $msg) = @_;
    my ($l_local) = $listaddr =~ /^(.*)\@/;
    my ($h_local) = (Email::Address->parse($msg->header("Delivered-To")))[0]->user;

    log "info", "processing message to $listaddr ($h_local, $l_local)";

    unless ($h_local =~ s/^$l_local//) {
        # policy error -- actual header local part does not match list address
        return undef;
    }

    if ($h_local eq "") {
        $msg->set_flag("workflow", "submit");
        $msg->set_flag("argv", []);
        return ("submit");
    }
    my ($delim) = $db->get_config("mail.delimiter");
    log_and_die "crit", "mail.delimiter not set" unless $delim;
    log "info", "h_local=$h_local delim=$delim";
    if (my ($name, $args) = $h_local =~ /^\Q$delim\E([^-]+)(?:-(.*))?$/) {
        $msg->set_flag("workflow", $name);
        $msg->set_flag("argv", [ split /-/, ($args || '') ]);
        return $name;
    }
    return undef;
}

# bounce -- Returns an error message to the original sender
#
# This is used as a catch-all procedure whenever a processing module has
# something to complain about. Processing modules are supposed to return
# either DROP or the name of a "template" used for the error message.

sub bounce {
    my ($db, $msg, $template, $argsref) = @_;
    if ($template eq "DROP") {
        log "info", "dropping message";
    } elsif ($template eq "TEMPFAIL") {
        log "info", "returning EX_TEMPFAIL";
        return $EX_TEMPFAIL;
    } else {
        log "info", "bouncing message back to %s: %s",
            $msg->header("Return-Path"), $template;

        my $rv = Lancelot::Send::sendtemplate($template, $db, $msg, $argsref);
        log "err", "error bouncing message: $rv" unless $rv;
    }
    return 0;
}

# For debugging.

sub dumpmsg {
    my ($msg) = @_;

    my ($sep) = "-" x 72 . "\n";
    print STDERR $sep;
    print STDERR "SMTP To: ", $msg->header("Delivered-To"), "\n";
    print STDERR "SMTP From: ", $msg->header("Return-Path"), "\n";
    print STDERR $sep;
    print $msg->as_string;
    print STDERR $sep;
}