qpsmtpd/plugins/badmailfrom

#!perl -w

=head1 NAME

check_badmailfrom - checks the badmailfrom config, with per-line reasons

=head1 DESCRIPTION

Reads the "badmailfrom" configuration like qmail-smtpd does.  From the
qmail-smtpd docs:

"Unacceptable envelope sender addresses. qmail-smtpd will reject every
recipient address for a message if the envelope sender address is
listed in badmailfrom. A line in badmailfrom may be of the form
@host, meaning every address at host."

You may include an optional message after the sender address (leave a space),
to be used when rejecting the sender.

=head1 CONFIGURATION

=head2 reject

  badmailfrom reject [ 0 | 1 | naughty ]

I<0> will not reject any connections.

I<1> will reject naughty senders.

I<connect> is the most efficient setting. It's also the default.

To reject at any other connection hook, use the I<naughty> setting and the
B<naughty> plugin.

=head1 PATTERNS

This plugin also supports regular expression matches. This allows
special patterns to be denied (e.g. FQDN-VERP, percent hack, bangs,
double ats).

Patterns are stored in the format pattern(\s+)response, where pattern
is a Perl pattern expression. Don't forget to anchor the pattern
(front ^ and back $) if you want to restrict it from matching
anywhere in the string.

 ^streamsendbouncer@.*\.mailengine1\.com$    Your right-hand side VERP doesn't fool me
 ^return.*@.*\.pidplate\.biz$                I don' want it regardless of subdomain
 ^admin.*\.ppoonn400\.com$


=head1 AUTHORS

2002 - Jim Winstead - initial author of badmailfrom

2010 - Johan Almqvist <johan-qpsmtpd@almqvist.net> - pattern matching plugin

2012 - Matt Simerson - merging of the two and plugin tests

=cut

sub register {
    my ($self,$qp) = (shift, shift);
    $self->{_args} = { @_ };

    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
};

sub hook_mail {
    my ($self, $transaction, $sender, %param) = @_;

    return DECLINED if $self->is_immune();

    my @badmailfrom = $self->qp->config('badmailfrom');
    if ( defined $self->{_badmailfrom_config} ) {       # testing
        @badmailfrom = @{$self->{_badmailfrom_config}};
    };
    return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom );

    my $host = lc $sender->host;
    my $from = lc($sender->user) . '@' . $host;

    for my $config (@badmailfrom) {
        $config =~ s/^\s+//g;   # trim leading whitespace
        my ($bad, $reason) = split /\s+/, $config, 2;
        next unless $bad;
        next unless $self->is_match( $from, $bad, $host );
        $reason ||= "Your envelope sender is in my badmailfrom list";
        $self->adjust_karma( -1 );
        return $self->get_reject( $reason );
    }

    $self->log(LOGINFO, "pass");
    return DECLINED;
}

sub is_match {
    my ( $self, $from, $bad, $host ) = @_;

    if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) {  # it's a regexp
        if ( $from =~ /$bad/ ) {
            $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
            return 1;
        };
        return;
    };

    $bad = lc $bad;
    if ( $bad !~ m/\@/ ) {
        $self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad");
        return;
    };
    if ( substr($bad,0,1) eq '@' ) {
        return 1 if $bad eq "\@$host";
        return;
    };
    return if $bad ne $from;
    return 1;
};

sub is_immune_sender {
    my ($self, $sender, $badmf ) = @_;

    if ( ! scalar @$badmf ) {
        $self->log(LOGDEBUG, 'skip, empty list');
        return 1;
    };

    if ( ! $sender || $sender->format eq '<>' ) {
        $self->log(LOGDEBUG, 'skip, null sender');
        return 1;
    };

    if ( ! $sender->host || ! $sender->user ) {
        $self->log(LOGDEBUG, 'skip, missing user or host');
        return 1;
    };

    return;
};