#!/usr/bin/perl

=head1 NAME

qmail_deliverable - Check that the recipient address is deliverable

=head1 DESCRIPTION

See the description of Qmail::Deliverable.

This B<qpsmtpd plugin> 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<smtproutes:>, 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 user-ext@example.org 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 is released into the public domain, and does not come with
warranty or guarantee of any kind. Use it at your own risk.

=head1 AUTHOR

Juerd <#####@juerd.nl>

=head1 SEE ALSO

L<Qmail::Deliverable>, L<qmail-deliverabled>, L<Qmail::Deliverable::Client>

=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;
    $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;

    $self->log(LOGINFO, sprintf("Unknown: 0x%02x", $rv)) if $rv and not $k;

    return DECLINED if $rv;

    $self->adjust_karma( -1 );
    return (DENY, "fail, 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{""};
}