File Coverage

qpsmtpd-plugin/qmail_deliverable

Criterion	Covered	Total	%
statement	55	86	63.9
branch	43	66	65.1
condition	6	15	40.0
subroutine	8	10	80.0
pod			n/a
total	112	177	63.2

#!/usr/bin/perl

=head1 NAME

qmail_deliverable - Check that the recipient address is deliverable

=head1 DESCRIPTION

See the description of Qmail::Deliverable.

This B uses the client/server interface and needs a running
qmail-deliverabled. If no connection can be made, deliverability is simply
assumed.

The modules LWP (libwww-perl) and HTTP::Daemon, available from CPAN, are
required for qmail-deliverabled and Qmail::Deliverable::Client.

=head1 CONFIGURATION

=over 4

=item server host:port

Hostname (or IP address), and port (both!) of the qmail-deliverabled server. If
none is specified, the default (127.0.0.1:8998) is used.

=item server smtproutes:host:port

If the specification is prepended by the literal text C, then for
recipient domains listed in your /var/qmail/control/smtproutes use their
respective hosts for the check. For other domains, the given host is used. The
port has to be the same across all servers.

Example:

    qmail_deliverable server smtproutes:127.0.0.1:8998

Use "smtproutes:8998" (no second colon) to simply skip the deliverability
check for domains not listed in smtproutes.

=item vpopmail_ext [ 0 | 1 ]

Is vpopmail configured with the qmail-ext feature enabled? If so, this config
option must be enabled in order for [e-mail] addresses to work.

Default: 0

=back

=head1 CAVEATS

Given a null host in smtproutes, the normal MX lookup should be used. This
plugin does not do this, because we don't want to harrass arbitrary servers.

Connection failure is *faked* when there is no smtproute.

=head1 LEGAL

This software does not come with warranty or guarantee of any kind. Use it at
your own risk.

This software may be redistributed under the terms of the GPL, LGPL, modified
BSD, or Artistic license, or any of the other OSI approved licenses listed at
http://www.opensource.org/licenses/alphabetical. Distribution is allowed under
all of these these licenses, or any smaller subset of multiple or just one of
these licenses.

When using a packaged version, please refer to the package metadata to see
under which license terms it was distributed. Alternatively, a distributor may
choose to replace the LICENSE section of the documentation and/or include a
LICENSE file to reflect the license(s) they chose to redistribute under.

=head1 AUTHORS

=over 4

=item *

Juerd Waalboer <#####@juerd.nl> (original author)

=item *

Matt Simerson  (current maintainer)

=back

=head1 CONTRIBUTORS

=over 4

=item *

Martin Sluka

=back

=head1 SEE ALSO

L, L, L

=cut

#################################
#################################

BEGIN {
    use FindBin qw($Bin $Script);
    if ( not $INC{'Qpsmtpd.pm'} ) {
        my $dir = '$PLUGINS_DIRECTORY';
        -d and $dir = $_ for qw(
            /home/qpsmtpd/plugins
            /home/smtp/qpsmtpd/plugins
            /usr/local/qpsmtpd/plugins
            /usr/local/share/qpsmtpd/plugins
            /usr/share/qpsmtpd/plugins
        );

        my $file = "the 'plugins' configuration file";
        -f and $file = $_ for qw(
            /home/qpsmtpd/config/plugins
            /home/smtp/qpsmtpd/config/plugins
            /usr/local/qpsmtpd/config/plugins
            /usr/local/etc/qpsmtpd/plugins
            /etc/qpsmtpd/plugins
        );

        # "die" would print "BEGIN failed" garbage
        print STDERR <<"END";

This is a plugin for qpsmtpd and should not be run manually.

To install the plugin:

    ln -s $Bin/$Script $dir/

And add "$Script server 127.0.0.1:8998" to $file, before rcpt_ok.
For configuration instructions, read "man $Script"

(Paths may vary.)

END
        exit 255;
    }
}

#################################
#################################

use strict;
use warnings;

use Qpsmtpd::Constants;
use Qmail::Deliverable::Client qw(deliverable);

my %smtproutes;
my $shared_domain;    # global variable to be closed over by the SERVER callback

sub register {
    my ( $self, $qp, @args ) = @_;
    if ( @args % 2 ) {
        $self->log( LOGWARN, "Odd number of arguments, using default config" );
    }
    else {
        my %args = @args;
        if ( $args{server} && $args{server} =~ /^smtproutes:/ ) {

            my ( $fallback, $port ) = $args{server} =~ /:(?:(.*?):?)(\d+)/;

            open my $fh, "/var/qmail/control/smtproutes"
                or warn "Could not read smtproutes";
            for ( readline $fh ) {
                my ( $domain, $mx ) = /^(.*?) : \[? ( [^\]:\s]* )/x;
                $smtproutes{$domain} = $mx;
            }

            $Qmail::Deliverable::Client::SERVER = sub {
                my $server = _smtproute($shared_domain);
                return "$server:$port"   if defined $server;
                return "$fallback:$port" if defined $fallback;
                return;
            };

        }
        elsif ( $args{server} ) {
            $Qmail::Deliverable::Client::SERVER = $args{server};
        }

        if ( $args{vpopmail_ext} ) {
            $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext};
        }
    }
    $self->register_hook( "rcpt", "rcpt_handler" );
}

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

    #return DECLINED if $self->is_immune(); # requires QP 0.90+

    my $address = $rcpt->address;
    $self->log( LOGDEBUG, "Checking deliverability for recipient '$address'" );

    $shared_domain = $rcpt->host;

    my $rv = deliverable $address;

    if ( not defined $rv or not length $rv ) {
        $self->log( LOGWARN, "error (unknown) checking '$address'" );
        return DECLINED;
    }

    my $k = 0;    # known status code
    $self->log( LOGINFO, "error, permission failure" ),        $k++ if $rv == 0x11;
    $self->log( LOGINFO, "pass, qmail-command in dot-qmail" ), $k++ if $rv == 0x12;
    $self->log( LOGINFO, "pass, bouncesaying with program" ),  $k++ if $rv == 0x13;
    if ( $rv == 0x14 ) {
        my $s = $transaction->sender->address;
        return ( DENY, "fail, mailing lists do not accept null senders" )
            if ( !$s || $s eq '<>' );
        $self->log( LOGINFO, "pass, ezmlm list" );
        $k++;
    }
    $self->log( LOGINFO, "Temporarily undeliverable: group/world writable" ), $k++
        if $rv == 0x21;
    $self->log( LOGINFO, "Temporarily undeliverable: sticky home directory" ), $k++
        if $rv == 0x22;
    $self->log( LOGINFO, "error, $Qmail::Deliverable::Client::ERROR" ), $k++
        if $rv == 0x2f;
    $self->log( LOGINFO, "pass, normal delivery" ),    $k++ if $rv == 0xf1;
    $self->log( LOGINFO, "pass, vpopmail dir" ),       $k++ if $rv == 0xf2;
    $self->log( LOGINFO, "pass, vpopmail alias" ),     $k++ if $rv == 0xf3;
    $self->log( LOGINFO, "pass, vpopmail catchall" ),  $k++ if $rv == 0xf4;
    $self->log( LOGINFO, "pass, vpopmail vuser" ),     $k++ if $rv == 0xf5;
    $self->log( LOGINFO, "pass, vpopmail qmail-ext" ), $k++ if $rv == 0xf6;
    $self->log( LOGINFO, "error, SHOULD NOT HAPPEN" ), $k++ if $rv == 0xfe;
    $self->log( LOGINFO, "fail, address not local" ),  $k++ if $rv == 0xff;

    if ($rv) {
        $self->log( LOGINFO, sprintf( "error, unknown: 0x%02x", $rv ) ) if not $k;
        return DECLINED;
    }

    return ( DENY, "Sorry, no mailbox by that name. qd (#5.1.1)" );
}

sub _smtproute {
    my ($domain) = @_;
    my @parts    = split /\./, $domain;
    if ( exists $smtproutes{$domain} ) {
        return undef if $smtproutes{$domain} eq "";
        return $smtproutes{$domain};
    }
    for ( reverse 1 .. @parts ) {
        my $wildcard = join "", map ".$_", @parts[ -$_ .. -1 ];
        if ( exists $smtproutes{$wildcard} ) {
            return undef if $smtproutes{$wildcard} eq "";
            return $smtproutes{$wildcard};
        }
    }
    return undef if not exists $smtproutes{""};
    return undef if $smtproutes{""} eq "";
    return $smtproutes{""};
}