#!perl -w

=head1 NAME

resolvable_fromhost

=head1 SYNOPSIS

Determine if the from host resolves to a valid MX or host.

=head1 DESCRIPTION

The fromhost is the part of the email address after the @ symbol, provided by
the sending server during the SMTP conversation. This is usually, but not
always, the same as the hostname in the From: header.

B<resolvable_fromhost> tests to see if the fromhost resolves. It saves the 
results in the transaction note I<resolvable_fromhost> where other plugins can
use that information. Typical results are:

 a  - fromhost resolved as an A record
 mx - fromhost has valid MX record(s)
 ip - fromhost was an IP
 whitelist - skipped checks due to whitelisting
 null - null sender
 config - fromhost not resolvable, but I<reject 0> was set.

Any other result is an error message with details of the failure.

If B<resolvable_fromhost> is enabled, the from hostname is also stored in
I<resolvable_fromhost_host>, making it accessible when $sender is not.

=head1 CONFIGURATION

=head2 reject < 0 | 1 | naughty >

If I<reject 1> is set, the old require_resolvable_fromhost plugin behavior of
temporary rejection is the default.

 resolvable_fromhost reject [ 0 | 1 | naughty ]

Default: 1

=head2 reject_type

 reject_type [ perm | temp ]

Set I<reject_type perm> to reject mail instead of deferring it.

Default: temp (temporary, aka soft, aka 4xx).

=head1 EXAMPLE LOG ENTRIES

 80072 (mail) resolvable_fromhost: pass, googlegroups.com has MX at gmr-smtp-in.l.google.com
 80108 (mail) resolvable_fromhost: pass, zerobarriers.net has MX at zerobarriers.net
 80148 (mail) resolvable_fromhost: pass, uhin.com has MX at filter.itsafemail.com
 86627 (mail) resolvable_fromhost: palmalar.com has no MX
 86627 (mail) resolvable_fromhost: fail, palmalar.com (SERVFAIL)

=encoding UTF8

=head1 AUTHORS

2012 - Matt Simerson - refactored, added: POD, tests, reject, reject_type

2002 - Ask Bjørn Hansen - intial plugin

=cut

use strict;
use warnings;

use lib 'lib';
use Qpsmtpd::Constants;
use Qpsmtpd::DSN;
use Qpsmtpd::TcpServer;

use Socket;
use Net::DNS qw(mx);
use Net::IP qw(:PROC);

my %invalid  = ();
my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6();

sub register {
    my ($self, $qp, %args) = @_;

    foreach (keys %args) {
        $self->{_args}->{$_} = $args{$_};
    }
    if (!defined $self->{_args}{reject}) {
        $self->{_args}{reject} = 1;
    }
    $self->{_args}{reject_type} ||= 'soft';

    $self->{resolver} = $self->get_resolver(timeout => 30);
}

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

    return DECLINED if $self->is_immune();

    if ($sender eq '<>') {
        $transaction->notes('resolvable_fromhost', 'null');
        $self->log(LOGINFO, "pass, null sender");
        return DECLINED;
    }

    $self->populate_invalid_networks();
    my $resolved = $self->check_dns($sender->host, $transaction);

    return DECLINED if $resolved;    # success, no need to continue
         #return DECLINED if $sender->host;  # reject later

    my $result = $transaction->notes('resolvable_fromhost') or do {
        if ($self->{_args}{reject}) {
            ;
            $self->log(LOGINFO, 'fail, missing result');
            return Qpsmtpd::DSN->temp_resolver_failed($self->get_reject_type(),
                                                      '');
        }
        $self->log(LOGINFO, 'fail, tolerated, missing result');
        return DECLINED;
    };

    return DECLINED if $result =~ /^(?:a|ip|mx)$/;                   # success
    return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/;    # immunity

    $self->adjust_karma(-1);

    if (!$self->{_args}{reject}) {
        ;
        $self->log(LOGINFO, "fail, tolerated, $result");
        return DECLINED;
    }

    $self->log(LOGINFO, "fail, $result");                            # log error
    return
      Qpsmtpd::DSN->addr_bad_from_system($self->get_reject_type(),
                                        "FQDN required in the envelope sender");
}

sub check_dns {
    my ($self, $host, $transaction) = @_;

    # we can't even parse a hostname out of the address
    if (!$host) {
        $transaction->notes('resolvable_fromhost', 'unparsable host');
        $self->adjust_karma(-1);
        return;
    }

    $transaction->notes('resolvable_fromhost_host', $host);

    if ($host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/) {
        $self->log(LOGINFO, "skip, $host is an IP");
        $transaction->notes('resolvable_fromhost', 'ip');
        $self->adjust_karma(-1);
        return 1;
    }

    my $res = $self->get_resolver(timeout => 30);

    my $has_mx = $self->get_and_validate_mx($host, $transaction);
    return 1 if $has_mx == 1;     # success, has MX!
    return   if $has_mx == -1;    # has invalid MX records
                                  # at this point, no MX for fh is resolvable

    my @host_answers = $self->get_host_records($host, $transaction);
    foreach my $rr (@host_answers) {
        if ($rr->type eq 'A' || $rr->type eq 'AAAA') {
            $self->log(LOGINFO, "pass, found A for $host");
            $transaction->notes('resolvable_fromhost', 'a');
            return $self->ip_is_valid($rr->address);
        }
        if ($rr->type eq 'MX') {
            $self->log(LOGINFO, "pass, found MX for $host");
            $transaction->notes('resolvable_fromhost', 'mx');
            return $self->mx_address_resolves($rr->exchange, $host);
        }
    }
    return;
}

sub ip_is_valid {
    my ($self, $ip) = @_;
    ### while (($net,$mask) = each %invalid) {
    ###      ... does NOT reset to beginning, will start on
    ###      2nd invocation after where it denied the first time..., so
    ###      2nd time the same "MAIL FROM" would be accepted!
    foreach my $net (keys %invalid) {
        my $mask = $invalid{$net};
        $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
        return if $net eq join('.', unpack("C4", inet_aton($ip) & $mask));
    }
    return 1;
}

sub get_and_validate_mx {
    my ($self, $host, $transaction) = @_;

    my @mx = mx($self->{resolver}, $host);
    if (!scalar @mx) {    # no mx records
        $self->adjust_karma(-1);
        $self->log(LOGINFO, "$host has no MX");
        return 0;
    }

    foreach my $mx (@mx) {

        # if any MX is valid, then we consider the domain resolvable
        if ($self->mx_address_resolves($mx->exchange, $host)) {
            $self->log(LOGINFO, "pass, $host has MX at " . $mx->exchange);
            $transaction->notes('resolvable_fromhost', 'mx');
            return 1;
        }
    }

    # if there are MX records, and we got here, none are valid
    #$self->log(LOGINFO, "fail, invalid MX for $host");
    $transaction->notes('resolvable_fromhost', "invalid MX for $host");
    $self->adjust_karma(-1);
    return -1;
}

sub get_host_records {
    my ($self, $host, $transaction) = @_;

    my @answers;
    my $res = $self->{resolver};
    my $query = $res->search($host);

    if ($query) {
        foreach my $rrA ($query->answer) {
            push(@answers, $rrA);
        }
    }

    if ($has_ipv6) {
        $query = $res->search($host, 'AAAA');
        if ($query) {
            foreach my $rrAAAA ($query->answer) {
                push(@answers, $rrAAAA);
            }
        }
    }

    if (!scalar @answers) {
        if ($res->errorstring ne 'NXDOMAIN') {
            $self->log(LOGWARN, "fail, query for $host, ", $res->errorstring);
        }
        return;
    }

    return @answers;
}

sub mx_address_resolves {
    my ($self, $name, $fromhost) = @_;

    # IP in MX
    if (ip_is_ipv4($name) || ip_is_ipv6($name)) {
        return $self->ip_is_valid($name);
    };

    my $res = $self->get_resolver();
    my @mx_answers = $self->resolve_a($name);

    if ($has_ipv6) {
        push @mx_answers, $self->resolve_aaaa($name);
    }

    if (!@mx_answers) {
        if ($res->errorstring eq 'NXDOMAIN') {
            $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring);
        }
        return;
    }

    return if ! scalar @mx_answers;
    return $self->ip_is_valid($mx_answers[0]);
}

sub populate_invalid_networks {
    my $self = shift;

    foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
        $i =~ s/^\s*//;    # trim leading spaces
        $i =~ s/\s*$//;    # trim trailing spaces
        if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
            $invalid{$1} = $3;
        }
    }
}