=head1 NAME

aliases_check - check recipients against aliases file

=head1 DESCRIPTION

This plugin looks up recipients (argument to the RCPT TO command) in an
alias file.
Recipients which are not found are immediately rejected.
For each found recipient, the recursive expansion of the alias and the
per-recipient options (if any) are noted. Typically, the aliases_rewrite
plugin is then used to replace the recipient list. The options can be
used by other modules to implement different behaviour for different
recipients.

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>.

FIXME: This plugin now uses address notes instead of transaction notes.

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).

If the option "nodetail" is specified for an alias, the detail string is
omitted both when that alias is expanded and when the alias appears in
the expansion of another alias. This is useful if some addresses are
forwarded to an MTA which doesn't support detail strings (like Lotus
Dominino).

=head1 HOOKS

=over

=item rcpt
    
check_rcpt

=back

=head1 TRANSACTION NOTES

This plugin fills in two transaction notes with information about the
recipients:

=over 

=item expanded_recipients

A reference to a hash of arrays. The keys of the hash are the recipients
as passed in the RCPT commands and as stored in
$transaction->recipients. Each value is a list of addresses this
recipient should be replaced with. All addresses are strings, not
Qpsmtpd::Address objects, and they are full RFC-2821-style addresses,
except that delimiting angle brackets are omitted.

So the aliases file from the example above will result in the followin
hash:

    {
        'hjp@wsr.ac.at'          => [ 'hjp@asherah.wsr.ac.at' },
        'peter.holzer@wsr.ac.at' => [ 'hjp@asherah.wsr.ac.at' },
        ...
        'postmaster@wsr.ac.at'   => [
                                      'hjp@asherah.wsr.ac.at',
                                      'gina@wsr.ac.at'
                                    ],
        ...
    }

Typically a plugin hooking into data_post or queue (e.g.,
aliases_rewrite) will then replace all recipients with the addresses in
this note before queuing the message.


=item recipient_options

A reference to a hash of hashes. The keys are the recipients (same as in
expanded_recipients - i.e., I<before> expansion), the values are hashes
of options. This plugin produces only simple key/value pairs, but
theoretically the options couls be arbitrarily complex data structures.

The aliases file from the example results in the following
recipient_options note:

    {
        'hjp@wsr.ac.at' => {
                               denysoft_greylist => 1,
                               spamassassin_reject_threshold => 10
                           },
        'peter.holzer@wsr.ac.at' => {
                               denysoft_greylist => 1,
                               spamassassin_reject_threshold => 10
                           },
        ...
    }

=back

=cut

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

my $al;
my $al_ts = 0;
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) {
		$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++) {
	$self->log(LOGDEBUG, "aliases: set_option: \$kc[$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 $configdir = $self->qp->config_dir('aliases');

    # check if on disk config has changed
    my $ts = 0;
    for my $file ("$configdir/aliases", "$configdir/aliases.d", glob("$configdir/aliases.d/*")) {
	my $filets = (stat($file))[9] || 0;
	$ts = $filets if ($filets > $ts);
    }
    $self->log(LOGINFO, "ts = $ts, al_ts = $al_ts");

    # reload if it has
    if ($ts > $al_ts) {
	$al = undef;
	for my $file ("$configdir/aliases", glob("$configdir/aliases.d/*")) {
	    $self->parse_al1($file);
	}
	$al_ts = $ts;
    }
    my $t1 = time();

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

}


sub register {
    my ($self, $qp, @args) = @_;
    $self->log(LOGDEBUG, "register called on $self");
    %{$self->{_args}} = @args;

    if (defined $self->{_args}{log_expn}) {
	$self->{_args}{log_expn} = log_level($self->{_args}{log_expn}) 
	    unless $self->{_args}{log_expn} =~ m/^\d+$/;
    } else {
	$self->{_args}{log_expn} = LOGDEBUG;
    }

    $self->register_hook("rcpt", "check_rcpt");
    $self->register_hook("pre-connection", "pre_connection");

    # parse once during register for qpsmtpd-tcpserver.
    # qpsmtpd-forkserver will check in each pre-connection hook if
    # reparsing is needed.
    $self->parse_al();
}

sub pre_connection {
    my ($self, $qp) = @_;
    $self->log(LOGDEBUG, "pre_connection called on $self");

    $self->parse_al();

    return (DECLINED, "");
}

# expand the given alias, returnung an arrayref of mailaddresses.
#
# $detail is a detail string which is inserted into every expanded
# mail address.
#
# if $null_ok is set, an alias which isn't found expands to itself.
#
# $seen is a hashref used to avoid infinite recursion.

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");
	my $o = $self->alias_options($alias);
	$detail = "" if  $o && $o->{nodetail};
	for (@$e) {
	    my $o = $self->alias_options($_);
	    my $d = ( $o && $o->{nodetail} ) ? "" : $detail;
	    my $e1 = $self->expand_alias($_, $d, 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'");
	$e = $al->{"*\@$domain"}{exp};
	$self->log(LOGDEBUG, "result = " . ($e || "undef"));
	if ($e) {
	    $self->log(LOGDEBUG, "success (wildcard) -> recursing");
	    for (@$e) {
		my ($mailbox, $server) = split(/@/);
		$_ = $mailbox . ($detail ? "+$detail" : "") .
		    '@' . $server;
		s/\*/$local/;
		($mailbox, $server) = split(/@/);
		if ($mailbox =~ m/(.*?)\+(.*)/) {
		    $mailbox = $1;
		    $detail = $2;
		}
		$_ = "$mailbox\@$server";
		my $e1 = $self->expand_alias($_, $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();
    $self->log(LOGDEBUG, "$alias expanded to ",
		 ($exp ? scalar(@$exp) : 0), " recipients in : ",
		 $t1 - $t0, " seconds");
    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;
    }
}

=head1 METHODS

=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 and $connection->relay_client is not set,
the request is DENYd, otherwise 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).

XXX: This plugin currently ALWAYS DECLINES, so there must be another
plugin after it which DENYs if there are no valid recipients. I'm not
sure why I changed this, maybe to allow lookup in several user
databases?

=cut

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

    # get current list of recipients.
    # XXX - what for? Shouldn't we just use $recipient->address here?
    my $deliver_to = $recipient->notes('deliver_to');
    my @orecipients;
    if ($deliver_to) {
	@orecipients = @$deliver_to;
    } else {
	@orecipients = $recipient->address;
    }

    my @nrecipients;
    for my $orcpt (@orecipients) {

	# split recipient into local part, detail and domain
	# (local part and domain are case insensitive)
	#
	my $orcpta = Qpsmtpd::Address->new($orcpt);
	my $local_part = $orcpta->user;
	my $detail;
	if ($local_part =~ m/([^+]+)\+(.*)/) {
	    $local_part = $1;
	    $detail = $2;
	}
	$local_part = lc $local_part;
	my $domain = lc $orcpta->host;
	my $rcpt = "$local_part\@$domain";

	# look up alias
	my $e = $self->expand_alias($rcpt, $detail, 0);
	push @nrecipients, @$e if $e;
    }

    if (!@nrecipients && $self->qp->connection->relay_client()) {
	@nrecipients = @orecipients;
    }

    $recipient->notes('deliver_to', \@nrecipients);
    $self->log($self->{_args}{log_expn}, "expn: set recipient note deliver_to to \@nrecipients");
    $recipient->notes('options', $self->alias_options($recipient->address));
    $self->log($self->{_args}{log_expn}, "expn: set recipient note options");

    my $d = Data::Dumper->new([$recipient]);
    $d->Terse(1);
    $d->Indent(0);
    $self->log($self->{_args}{log_expn}, "expn: recipient;" . $d->Dump);

    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 COPYRIGHT AND LICENSE

Copyright (c) 2003-2012 Peter J. Holzer

This plugin is licensed under the same terms as the qpsmtpd package
itself.
Please see the LICENSE file included with qpsmtpd for details.

=cut