#!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)

=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';
}

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, missing result, reject disabled' );
        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, reject disabled, $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 = new Net::DNS::Resolver(dnsrch => 0);
    $res->tcp_timeout(30);
    $res->udp_timeout(30);

    my $has_mx = $self->get_and_validate_mx( $res, $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( $res, $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) = @_;
    my ($net, $mask);
    ### 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 $net (keys %invalid) {
        $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, $res, $host, $transaction ) = @_;

    my @mx = mx($res, $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, $res, $host, $transaction ) = @_;

    my @answers;
    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
    return $self->ip_is_valid($name) if ip_is_ipv4($name) || ip_is_ipv6($name);

    my $res = new Net::DNS::Resolver(dnsrch => 0);
    my @mx_answers;
    my $query = $res->search($name, 'A');
    if ($query) {
        foreach my $rrA ($query->answer) {
            push(@mx_answers, $rrA);
        }
    }
    if ($has_ipv6) {
        my $query = $res->search($name, 'AAAA');
        if ($query) {
            foreach my $rrAAAA ($query->answer) {
                push(@mx_answers, $rrAAAA);
            }
        }
    }
    if (! @mx_answers) {
        if ( $res->errorstring eq 'NXDOMAIN' ) {
            $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring);
        };
        return;
    }

    foreach my $rr (@mx_answers) {
        next if ( $rr->type ne 'A' && $rr->type ne 'AAAA' );
        return $self->ip_is_valid($rr->address);
    }

    return;
}

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;
        }
    }
};