#!/usr/bin/perl -w

=head1 NAME

do_aliases - plugin for qpsmtpd which expands aliases

=head1 DESCRIPTION

qpsmtpd hooks we implement:

rcpt:

  reject domains we don't accept, and users we don't accept
  [check_delivery does qmail file processing]

data_post:

  we do nothing; virus/spam filters apply

queue:

  we do forwarding, program delivery, and local delivery

=head1 SEE ALSO 

=head2 Other Qpsmtpd plugins

aliases http://www.hjp.at/projekte/qpsmtpd/aliases/ 

    reads $QPHOME/config/aliases
    unlike /etc/aliases:
        final delivery is a complete email address.
        part after + is passed through to expansions of user before +.
        supports Qpsmtp plugin options in parens on left hand side.
        left hand side can be a list.
        right hand side is simply split by /,/ (problem if a pipe) 

    the "rcpt" hook (check_rcpt) puts expansion into transaction notes.
    the "data_post" hook (replace_rcpt) replaces the recipients with those in the note "expanded_recipients"
    
    requires a patch to Qpsmtpd::Transaction http://www.nntp.perl.org/group/perl.qpsmtpd/604
    sub clear_recipients {
        my $self = shift;
        $self->{_recipients} = [];
    }

check_delivery http://gw.nsa.co.il/qpsmtpd/check_delivery

    parses qmail config files
    acts only at "rcpt" time

check_goodrcpto  http://www.openfusion.com.au/labs/qpsmtpd/check_goodrcptto
    "goodrcptto" file. 
    'fred@domain.com' or 'postmaster' or '@domain.com'. removes any extension on the address being tested.



=head2 perl modules for aliases

Mail::ExpandAliases

    use Mail::ExpandAliases;
    my $ma = Mail::ExpandAliases->new("/etc/aliases");
    my @list = $ma->expand("listname");

    recursive, and returns argument if no expansions. does loop detection.
    does not read .forward files. does not alter files.

Mail::Alias

    reads and writes. does expansion with recursion, return argument if none.

http://www.cpan.org/modules/by-authors/id/TOMC/scripts/getalias.gz

    reads aliases.db. reads user .forward.
    Tom Christiansen

=cut

use File::Temp qw(tempfile);
 
sub register {
  my ($self, $qp, @args) = @_;
  $self->register_hook("rcpt", "aliases_rcpt");
  $self->register_hook("queue", "aliases_queue");

  my $timeout = $self->{timeout} = $self->qp->config("queue_timeout") || 0;
  $self->log(LOGINFO, "registered with timeout=$timeout");

  while (@args) {
      $self->{"_myparam"}->{pop @args}=pop @args;
  }
  $self->{"_myparam"} ||= '17';
}

use Mail::ExpandAliases;
 
our $EXCLUSIVE_RESULT = DECLINED;

# "rcpt" handler
sub aliases_rcpt {
    my ($self, $transaction, $recipient) = @_;

    my $ma = Mail::ExpandAliases->new("/etc/aliases");
    $self->{'_aliases'} = $ma;

    my $exprcpt = $transaction->notes('expanded_recipients');
    $exprcpt = {} unless $exprcpt;

    # actual address in RCPT 
    my $orig = $recipient->address;

    # before lookup, lc everything, and remove stuff after +
    my $local_part = $recipient->user;
    my $detail;
    if ($local_part =~ m/([^+]+)\+(.*)/) {
	$local_part = $1;
	$detail = $2;
    }
    $local_part = lc $local_part;
    my $domain = lc $recipient->host;
    my $rcpt = "$local_part\@$domain";
    
    # first check expansion for full address, then just local part
    my $expanded_address = $rcpt;
    my @expanded = $ma->expand($expanded_address);
    if (@expanded == 0 || (@expanded == 1 && $rcpt eq $expanded[0])) {
	$expanded_address = $local_part;
	@expanded = $ma->expand($local_part);
	$self->log(LOGINFO, "no expansions for <$rcpt>; using expansion for local part <$local_part>: @expanded");
    }
    else {
	$expanded_address = $rcpt;
	$self->log(LOGINFO, "expanded <$rcpt> to: @expanded");
    }

    # Mail::ExpandAliases expand() returns its argument if there are no expansions.
    # it returns an empty list if it is in the aliases file but goes nowhere
    if (@expanded == 0) {
	my $mess = "there is an alias entry <$orig> but it expands to nothing";
	$self->log(LOGWARN, $mess);
	return(DENY, $mess);
    }
    if (@expanded == 1 && $expanded_address eq $expanded[0]) {
	my $mess = "no aliases for <$orig>";
	$self->log(LOGWARN, $mess);
	return($EXCLUSIVE_RESULT, $mess);
    }

    # save for later use in queue
    $exprcpt->{$orig} = [@expanded];
    $transaction->notes('expanded_recipients', $exprcpt);

    # we return declined, in case some other plugin has something to say about this one. because we just wanted to work by side-effect 
    return(DECLINED, "expanded");
}

# necessary with -T since we are piping to another command
BEGIN {
    delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
    # $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
}

# "queue" handler
sub aliases_queue {
    my ($self, $transaction) = @_;

    my $exprcpt = $transaction->notes('expanded_recipients');
    if (!$exprcpt) {
	my $msg = "do_aliases rcpt declined all, so queue will too";
	$self->log(LOGWARN, $msg);
	return(DECLINED, $msg);
    }

    # loop through recipients that have been accepted by all plugins,
    # and collect expansions.
    my @new_recipients = ();
    for ($transaction->recipients()) {
	my $addr = $_->address();
	my $e = $exprcpt->{$addr};
	if ($e) {
	    push (@new_recipients, @$e);
	    $self->log(LOGINFO, "address $addr was expanded to: (", join(',', @$e), ")");
	}
	else {
	    $self->log(LOGWARN, "address $addr has no expanded recipients, so ignoring it");
	}
    }

    # could replace recipients in transaction, but other plugins may not like addresses with "|"
    if (0) {
	$transaction->recipients(map {Mail::Address->new('',$_)} @new_recipients);
    }

    # we've already said we are going to accept the original RCPT list.
    # we really can't go failing now.....
    
    # TODO: we've lost the original, prior to expansion

    my @results = ();
    my ($whole_result,$whole_msg);
    for (@new_recipients) { 
	my ($result, $msg);
	# a piped command. parser already removed any surrounding quotes. 
	# if the input was |"exit 0" then the parser removed the trailing quote but not the embedded one.
	if (m/^\|[\s\"]*(.*)/) {
	    my $cmd = $1;
	    ($result, $msg) = aliases_redirect($self, $transaction, $cmd);
	}
	# if we only want piped aliases, then do this
	# TODO: really should only decline if there is only one
	else {
	    $msg = "non-piped recipient '$_'";
	    $self->log(LOGWARN, $msg);
	    ($result, $msg) = ($EXCLUSIVE_RESULT, $msg);
	}
	push(@results,[$result,$msg]);
	# return worst result as the result of the whole thing
	($whole_result, $whole_msg) = ($result, $msg) if !$whole_result || $whole_result ne OK;
    }
    if (!$whole_result) {
	my $mess = "no recipients to queue to";
	$self->log(LOGWARN, $mess);
	return (DECLINED, $mess);
    }
    return ($whole_result, $whole_msg);
}

# we may want to read stdout/stderr of the command to figure out what went wrong.
# actually, we *better* get stdout Qpsmtpd/TcpServer will send it back directly
# to the smtp client.

# there are still various deadlock possibilities...

use File::Temp qw/tempfile/;

# TODO: implement timeout
sub run_open {
    my ($cmd, $getline, $timeout) = @_;

    my $tmpfile = new File::Temp();
    if (!open(CMD_IN, "|$cmd > $tmpfile 2>&1")) {
	return ($?);
    }

    while (my $line = &$getline()) {
	print CMD_IN $line;
    }
    close(CMD_IN);
    my $status = $?;

    my @outerrlines = ();
    if (open(TMP,"<$tmpfile")) {
	@outerrlines = <TMP>;
	close(TMP);
	# unlink($tmpfile);
    }

    return ($status, 0, [@outerrlines]);
}

use IPC::Open3;

use vars qw($ALIASES_DEBUG);
 
$ALIASES_DEBUG = 1;

sub run_open3 {
    my ($cmd, $getline, $timeout) = @_;

    my $childpid;

    # CHLD is expected. PIPE and ALRM are not.
    my $gotpipe;
    local $SIG{PIPE} = sub { 
	$gotpipe = 1;
	print STDERR "got SIGPIPE\n" if $ALIASES_DEBUG; 
    };

    # sigchild is expected
    my $gotchld;
    local $SIG{CHLD} = sub {
	$gotchld = 1;
	print STDERR "got SIGCHLD\n" if $ALIASES_DEBUG; 
    };
    my $gotalrm;
    local $SIG{ALRM} = sub {
	$gotalrm = 1;
	print STDERR "got SIGALRM\n" if $ALIASES_DEBUG;
	kill 9, $childpid;
    };

    local(*CMD_IN); local(*CMD_OUT); local(*CMD_ERR);
    alarm $timeout;
    $childpid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);
    if (!$childpid) {
	print STDERR "open3 '$cmd' failed\n" if $ALIASES_DEBUG;
	return ($?, 0);
    }

    while (my $line = &$getline()) {
	print CMD_IN $line;
    }
    close(CMD_IN);
    alarm 0;

    # get output before waitpid?
    # what about SIGPIPE, fail to exec
    
    my @outlines = <CMD_OUT>;
    my @errlines = <CMD_ERR>;

    waitpid($childpid, 0);
    return ($?, $gotalrm,[@outlines],[@errlines]);
}

use IPC::Run;

# todo: how know if timed out?
sub run_run {
    my ($cmd, $getline, $timeout) = @_;
    my @outlines = (); my @errlines = ();
    IPC::Run::run [$cmd], $getline, sub {push(@outlines,$_)}, sub{push(@errlines,$_)}, ($timeout ? IPC::Run::timeout($timeout) : ());
    return ($?,0,[@outlines],[@errlines]);
}

# internal function to handle a piped alias
sub aliases_redirect {
    my ($self, $transaction, $cmd) = @_;    

    $self->log(LOGINFO, "Running command '$cmd'");
    my $id = `id`;
    $self->log(LOGDEBUG, "As ruid=$<, euid=$>, rgid=$(, egid=$), id=$id)");

    # TODO: can't we just pipe the temp file we already have directly in? 
    # or avoid the temp file and send directly to this destination before receiving?
    # but that would mean a "data" hook that returns DONE (between "rcpt" and "data_post")
    # to avoid the builtin behavior of Qpsmtpd::SMTP::data.
    # that means missing virus checks and other things happening in "data_post"
    # and "queue". it also means that transaction->header($header) and
    # transaction->body_write($_) would never get called.
    # NOTE: Qpsmtpd::SMTP::data has hardcoded behavior of:
    #   adding a Received header,
    #   passing MailFrom => "COERCE" to Mail::Header
    #   adding a X-Qpsmtpd-Auth if $self->{_auth}
    my $in_header = 1;
    my $getl = sub {
	# we are sending multiple lines for the header at once, assuming the caller is ok with that.
	if ($in_header) {
	    $in_header = 0;
	    my $hs = $transaction->header->as_string;
	    $transaction->body_resetpos; 
	    $self->log(LOGDEBUG, "sending header string '$hs'");
	    return $hs;
	}
	return $transaction->body_getline();
    };
    my $timeout = $self->{timeout};
    my ($status, $timed_out, $out, $err) = run_open3($cmd, $getl, $timeout);
 
    my $exitcode = ($status >> 8);
    my $signal = ($status & 127);

    my $failure_reason;

    if ($timed_out) {$failure_reason = "timed out after $timeout seconds";}
    elsif ($signal) {$failure_reason = "exited with signal $signal";}
    elsif ($exitcode) {$failure_reason = "exited with exit code $exitcode";}
    $out ||= []; $err ||= [];
    if ($failure_reason) {
	my $combined = join('', (@$err, @$out)) || '';
	my ($firstline) = ($combined =~ m/^([^\r\n]*)/);
	my $mess = "command '$cmd' $failure_reason" . ($firstline ? "; first line of command output was: " . $firstline : '');
	$self->log(LOGERROR, $mess);
	$self->log(LOGDEBUG, "combined out and err from failed command:\n'$combined'");
	return (DENYSOFT, $mess);
    }
    $self->log(LOGDEBUG, "command '$cmd' successful; combined out and err is:\n'", join('', (@$err, @$out)), "'");

    return(OK, "queued"); 
} 

use Data::Dumper;

sub testme {
    my $ma = Mail::ExpandAliases->new("/etc/aliases");
    for my $al (('discuss' , 'discuss@lists.apacam.org')) {
	my @expand = $ma->expand($al);
	print STDERR "expand($al) -> ", Dumper(\@expand);
    }
    my $sent;
    my $getl = sub {if (!$sent) {$sent = 1; return "hello\n";} return undef;};

    no strict 'refs';
    # try these commands: 'cat', 'false', 'garbage'
    my $cmd = 'false';
    my $timeout = 0;
    for my $impl(qw(run_open3 run_open run_run)) {
	$sent = undef;
	my ($status,$istimeout, $out,$err) = &$impl($cmd, $getl, $timeout);
	$istimeout ||= 0;
	print STDERR $impl, "->($status,$istimeout,", 
	($out ? join("\n",@$out) : ''), 
	($err ? join("\n",@$err) : ''),
	")\n";
    }
}

1;