=head1 NAME

check_goodrcptto

=head1 DESCRIPTION

This plugin denies all recipients except those in the goodrcptto config file 
(i.e. like badrcptto, but whitelisting). It supports recipient username 
extension stripping, and both domain ('@domain.com') and username (bare
'postmaster') wildcard entries in the config file.

Useful where something like check_delivery is overkill or not an option
(e.g. relays, bastion hosts).

=head1 CONFIG

The following parameters can be passed to check_goodrcptto:

=over 4

=item extn <char>

If set, check_goodrcptto does its checks using both the username as given and 
the username stripped of any extensions beginning with <char>.

=item deny_note <name>

If set, check_goodrcptto will set a connection note with the given name when 
denying a recipient. If <name> is of the form 'name=value', then the specified
value will be used instead of the default '1'. If the connection note already
exists, the value will be incremented (if numeric), instead of set.


=back

=cut

my $VERSION = 0.03;

sub register {
  my ($self, $qp, %arg) = @_;
  $self->register_hook("rcpt", "check_goodrcptto");
  $self->{_extn} = $arg{extn} if $arg{extn};
  $self->{_deny_note} = $arg{deny_note} if $arg{deny_note};
}

sub check_goodrcptto {
  my ($self, $transaction, $recipient) = @_;
  return (DECLINED) if $self->qp->connection->relay_client;
  $self->log(LOGINFO, "stripping '$self->{_extn}' extensions") if $self->{_extn};
  my @goodrcptto = $self->qp->config("goodrcptto") or return (DECLINED);
  my $host = lc $recipient->host;
  my $user = lc $recipient->user;
  return (DECLINED) unless $host && $user;
  # Setup users and address stripped of extensions
  my (@parts, @users, @addresses);
  my $extn = $self->{_extn};
  if ($extn) {
    @parts = split /$extn/, $user;
    foreach (0..$#parts) {
      push @users, join $extn, @parts[0..$_];
    }
    $self->log(LOGDEBUG, "address includes extn '$extn', checking users: " . (join ' ', @users));
  } else {
    push @users, $user;
  }
  @addresses = map { $_ . "@" . $host } @users;
  for my $good (@goodrcptto) {
    $good =~ s/^\s*(\S+).*/\L$1/;
    foreach (@addresses) {
      return (DECLINED) if $good eq $_;
    }
    # Allow wildcard '@domain.com' entries
    return (DECLINED) if substr($good,0,1) eq '@' && $good eq "\@$host";
    # Allow wildcard bare 'username' entries e.g. 'postmaster'
    if (index($good,'@') < 0) {
      foreach (@users) {
        return (DECLINED) if $good eq $_;
      }
    }
  }
  $self->log(LOGWARN, "recipient $addresses[$#addresses] denied");
  # Set/increment the specified deny_note, if applicable
  if ($self->{_deny_note}) {
    my ($name, $value) = ($self->{_deny_note} =~ m/^([-\w]+)(?:=([\d.]+))?/);
    $value ||= 1;
    $self->qp->connection->notes($name, ($self->qp->connection->notes($name) || 0) + $value)
      if $name;
    $self->log(LOGDEBUG, "deny_note: $name=" . $self->qp->connection->notes($name));
  }
  return (DENY, "relaying denied $addresses[$#addresses]");
}

# arch-tag: 2d2195a5-27b0-465d-a68f-f425efae2cc0

