=head1 NAME

aliases - expand aliases

=head1 DESCRIPTION

This module looks up recipients (argument to the RCPT TO command) in an
alias file.
Recipients which are not found are immediately rejected.
After all recipients are known, the aliases are recursively expanded.

An alias can expand to one or more addresses,
a detail string (everything after '+' in the local part) is preserved in the expansion.

Duplicates are eliminated.

Unlike the sendmail aliases file, the aliases are complete email addresses, not just the local part.


=head1 CONFIGURATION

The aliases file is a simple text file, with one alias-pattern/expansion pair per line, separated by a colon.

The alias pattern consists of a list of local parts, an @ sign and a list of
domains, optionally followed by a parenthesized list of of options.

The expansion consists of a list of email-addresses.

Lists are comma-separated, whitespace is insignificant.

For example, consider the alias file:

    hjp,peter.holzer@wsr.ac.at,wifo.at: hjp@asherah.wsr.ac.at (denysoft_greylist, spamassassin_reject_threshold=10)
    postmaster@,wsr.ac.at,wifo.at: sysadm@wsr.ac.at
    sysadm@wsr.ac.at: hjp@wsr.ac.at,gina@wsr.ac.at

The addresses <postmaster>, <postmaster@wsr.ac.at> and <postmaster@wifo.ac.at> would 
all be expanded to <sysadm@wsr.ac.at>, which in turn would be expanded
to two adresses (<hjp@wsr.ac.at>, <gina@wsr.ac.at>), of which the first
would again be expanded to <hjp@asherah.wsr.ac.at>.

So if you send mail to <postmaster+test@wsr.ac.at>, it will be delivered
to <hjp+test@asherah.wsr.ac.at> and <gina+test@wsr.ac.at>.

The options are stored in the transaction notes with key recipient_options and
can be accessed by other plugins. They are not recursively expanded, however, so 
in the above example, the greylisting plugin would only be active for the 
hjp and peter.holzer addresses, not for postmaster and sysadm.

The ability to specify patterns doesn't add any functionality: The first
line in the example above is exactly equivalent to:

    hjp@wsr.ac.at: hjp@asherah.wsr.ac.at (denysoft_greylist, spamassassin_reject_threshold=10)
    peter.holzer@wsr.ac.at: hjp@asherah.wsr.ac.at (denysoft_greylist, spamassassin_reject_threshold=10)
    hjp@wifo.at: hjp@asherah.wsr.ac.at (denysoft_greylist, spamassassin_reject_threshold=10)
    peter.holzer@wifo.at: hjp@asherah.wsr.ac.at (denysoft_greylist, spamassassin_reject_threshold=10)

But it should help to keep the expansions consistent.

The order of lines is not significant. If two lines for the same alias
exist, it is undefined which one is used. (In the current
implementation, later entries override earlier ones but this should not
be relied upon).

=head1 HOOKS

=over

=item rcpt
    
check_rcpt

=item data_post

replace_rcpt

=back

=cut

use strict;
use Time::HiRes qw(time);
use Data::Dumper;

my $al;
sub parse_al1 {
    my ($self, $file) = @_;

    my $t0 = time();
    open(UL, "<$file");
    while (<UL>) {
	s/#.*//;
	my $options;
	if (/(.*)\((.*)\)/) {
	    # options are parenthesized 
	    $options = $2;
	    $_ = $1;
	}
	s/\s+//gs;
	next if /^$/;
	my ($alias, $exp) = split(/:/);
	my ($a_local, $a_dom) = split(/\@/, $alias);
	my @locals = split(/,/, $a_local);
	my @domains = split(/,/, $a_dom);
	my @exp = split(/,/, $exp);
	for my $l (@locals) {
	    for my $d (@domains) {
		#print STDERR "$$ aliases: $l\@$d\n";
		$al->{"$l\@$d"}{exp} = [@exp];
		if ($options) {
		    my @opt = split(/,/, $options);
		    for my $o (@opt) {
			if ($o =~ m/(.*?)=(.*)/) {
			    my ($k, $v) = ($1, $2);
			    $k =~ s/^\s*(.*?)\s*$/$1/;
			    $v =~ s/^\s*(.*?)\s*$/$1/;
			    $self->set_option("$l\@$d", $k, $v);
			    $self->log(LOGDEBUG, "aliases: parse_al: option <$k>=<$v>");
			} else {
			    $o =~ s/^\s*(.*?)\s*$/$1/;
			    $self->set_option("$l\@$d", $o, 1);
			    $self->log(LOGDEBUG, "aliases: parse_al: option <$o>");
			}
		    }
		}
	    }
	}
    }
    close(UL);
    my $t1 = time();

    $self->log(LOGINFO, "parsed $file in ", $t1 - $t0, " seconds")
}

sub set_option {
    my ($self, $rcpt, $key, $value) = @_;
    $self->log(LOGDEBUG, "aliases: set_option: rcpt <$rcpt>, option <$key>=<$value>");
    my @kc = split('/', $key);
    my $n = $al->{$rcpt}{opt};
    unless ($n) {
	$n = $al->{$rcpt}{opt} = {};
    }
    for (my $i = 0; $i < $#kc; $i++) {
	unless (ref($n->{$kc[$i]} eq 'HASH')) {
	    $n = $n->{$kc[$i]} = {};
	}
    }
    $n->{$kc[$#kc]} = $value;

    my $d = Data::Dumper->new([$al->{$rcpt}{opt}], ["$al->{$rcpt}{opt}"]);
    $d->Indent(0);
    $self->log(LOGDEBUG, $d->Dump);
}


sub parse_al {
    my ($self) = @_;

    my $t0 = time();
    my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
    for my $file ("$QPHOME/config/aliases", glob("$QPHOME/config/aliases.d/*")) {
	$self->parse_al1($file);
    }
    my $t1 = time();

    $self->log(LOGINFO, "parsed aliases file(s) in ", $t1 - $t0, " seconds")

}


sub register {
    my ($self, $qp) = @_;

    print STDERR "$$ aliases: in register\n";
    $self->parse_al();

    $self->register_hook("rcpt", "check_rcpt");
    $self->register_hook("data_post", "replace_rcpt");
    print STDERR "$$ aliases: finished register\n";
}

sub expand_alias {
    my ($self, $alias, $detail, $null_ok, $seen) = @_;
    my $exp = undef;

    $self->log(LOGDEBUG, "expand_alias($alias, " . ($detail || 'undef'), ", $null_ok, {" . join(', ', keys %$seen) . "})");

    # check for infinite recursion
    return [ $alias] if ($seen->{$alias});
    $seen = { %$seen, $alias => 1 };

    my $t0 = time();
    $self->log(LOGDEBUG, "trying to expand '$alias'");
    my $e = $al->{$alias}{exp};
    $self->log(LOGDEBUG, "result = " . ($e || "undef"));

    if ($e) {
	$self->log(LOGDEBUG, "success -> recursing");
	for (@$e) {
	    my $e1 = $self->expand_alias($_, $detail, 1, $seen);
	    push @$exp, @$e1;
	}
    } else {
	$self->log(LOGDEBUG, "failure -> trying wildcard");
    
	$alias =~ m/(.*)@(.*)/;
	my ($local, $domain) = ($1, $2);
	$self->log(LOGDEBUG, "trying to expand '*\@$domain' (local=$local)");
	$e = $al->{"*\@$domain"}{exp};
	$self->log(LOGDEBUG, "result = " . ($e ? Dumper($e) : "undef"));
	if ($e) {
	    $self->log(LOGDEBUG, "success (wildcard) -> recursing");
	    for (@$e) {
		my ($mailbox, $server) = split(/@/);
		my $addr = $mailbox . ($detail ? "+$detail" : "") .
		    '@' . $server;
		$addr =~ s/\*/$local/;
		($mailbox, $server) = split(/@/, $addr);
		if ($mailbox =~ m/(.*?)\+(.*)/) {
		    $mailbox = $1;
		    $detail = $2;
		}
		$addr = "$mailbox\@$server";
		my $e1 = $self->expand_alias($addr, $detail, 1, $seen);
		push @$exp, @$e1;
	    }
	} elsif ($null_ok) {
	    $self->log(LOGDEBUG, "failure on wildcard but null_ok -> returning");
	    my ($mailbox, $server) = split(/@/, $alias);
	    $exp = [ 
		    $mailbox . ($detail ? "+$detail" : "") .
		    '@' . $server
		   ];
	}
    }
    my $t1 = time();
    print STDERR "$$ aliases: $alias expanded to ",
		 ($exp ? scalar(@$exp) : 0), " recipients in : ",
		 $t1 - $t0, " seconds\n";
    return $exp;
}


sub alias_options {
    my ($self, $alias) = @_;

    $self->log(LOGDEBUG, "looking up options for $alias");
    my $opt = $al->{$alias}{opt};
    if ($opt) {
	my $d = Data::Dumper->new([$opt], ['opt']);
	$d->Indent(0)->Terse(1);
	$self->log(LOGDEBUG, "found options: " . $d->Dump);
	return $opt
    }

    $alias =~ m/(.*)@(.*)/;
    my ($local, $domain) = ($1, $2);
    $opt = $al->{"*\@$domain"}{opt};
    if ($opt) {
	my $d = Data::Dumper->new([$opt], ['opt']);
	$d->Indent(0)->Terse(1);
	$self->log(LOGDEBUG, "found options: " . $d->Dump);
	return $opt
    } else {
	$self->log(LOGDEBUG, "found no options");
	return undef;
    }
}

=head2 rcpt: check_rcpt

The check_rcpt method plugs into the rcpt hook. It looks up the
recipient's email address in the aliases file, expands it, and stores
the result and per-address options (if any) in transaction notes.

If the address is not found, the request is DENYd, if it is found, the
request is DECLINED. This plugin should be run before any other plugin
which makes use of recipient_options. The last plugin to run must then
return OK for all recipients it doesn't DENY. (there is a rcpt_ok plugin 
which simply accepts all recipients which haven't yet been denied).

=cut

sub check_rcpt {
    my ($self, $transaction, $recipient) = @_;

    # get current list of recipients.
    my $exprcpt = $transaction->notes('expanded_recipients');
    $exprcpt = {} unless $exprcpt;

    # split recipient into local part, detail and domain
    # (local part and domain are case insensitive)
    #
    my $orig = $recipient->address;
    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";

    # look up alias
    my $e = $self->expand_alias($rcpt, $detail, 0);
    return (DENY, "no such user <$rcpt>") unless ($e);

    $exprcpt->{$orig} = $e;
    $transaction->notes('expanded_recipients', $exprcpt);
    $transaction->notes('recipient_options', $self->alias_options($rcpt));
    return (DECLINED, "");
}

=head2 data_post: replace_rcpt

Replace all recipients with the list collected in note 'expanded_recipients'.

=cut

sub replace_rcpt {
    my ($self, $transaction) = @_;

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

    print STDERR "$$ aliases: exprcpt", Dumper $exprcpt, "\n";
    print STDERR "$$ aliases: clearing recipients\n";
    my @new_recipients = ();
    for ($transaction->recipients()) {
	my $e = $exprcpt->{$_->address()};
	push (@new_recipients, @$e) if ($e);
	$self->log(LOGINFO, "replace_rcpt: recipient: ", $_->address(), " -> @$e\n");
    }
    return (DENY, "no recipients") unless @new_recipients;
    $transaction->clear_recipients();
    for (@new_recipients) {
	print STDERR "$$ aliases: adding $_\n";
	$transaction->add_recipient(Qpsmtpd::Address->new($_));
    }
    print STDERR "$$ aliases: checking recipients\n";
    for ($transaction->recipients()) {
	print STDERR "$$ aliases: recipient: ", $_->address(), "\n";
    }
    print STDERR "$$ aliases: checking recipients done\n";
    
    return DECLINED;
}

=head1 BUGS

None known (yet).

=head1 TODO

Parsing a text file is fast enough for a few thousand aliases. For
larger user bases the text file should be replaced by a database with
proper indexes (*DBM, relational, LDAP, whatever).

=head1 AUTHOR

Peter J. Holzer <hjp@wsr.ac.at>

=cut