Mail::SPF::Util - Mail::SPF utility class

    use Mail::SPF::Util;

    $hostname = Mail::SPF::Util->hostname;

    $ipv6_address_v4mapped =
        Mail::SPF::Util->ipv4_address_to_ipv6($ipv4_address);

    $ipv4_address =
        Mail::SPF::Util->ipv6_address_to_ipv4($ipv6_address_v4mapped);

    $is_v4mapped =
        Mail::SPF::Util->ipv6_address_is_ipv4_mapped($ipv6_address);

    $ip_address_string  = Mail::SPF::Util->ip_address_to_string($ip_address);
    $reverse_name       = Mail::SPF::Util->ip_address_reverse($ip_address);

    $validated_domain = Mail::SPF::Util->valid_domain_for_ip_address(
        $spf_server, $request,
        $ip_address, $domain,
        $find_best_match,       # defaults to false
        $accept_any_domain      # defaults to false
    );

#
# Mail::SPF::Util
# Mail::SPF utility class.
#
# (C) 2005-2008 Julian Mehnle <julian@mehnle.net>
#     2005      Shevek <cpan@anarres.org>
# $Id: Util.pm 50 2008-08-17 21:28:15Z Julian Mehnle $
#
##############################################################################

package Mail::SPF::Util;

use warnings;
use strict;

use utf8;  # Hack to keep Perl 5.6 from whining about /[\p{}]/.

use base 'Mail::SPF::Base';

use Mail::SPF::Exception;

use Error ':try';
use Sys::Hostname ();
use NetAddr::IP;

use constant TRUE   => (0 == 0);
use constant FALSE  => not TRUE;

use constant ipv4_mapped_ipv6_address_pattern =>
    qr/^::ffff:(\p{IsXDigit}{1,4}):(\p{IsXDigit}{1,4})/i;

# Interface:
##############################################################################

# Implementation:
##############################################################################

my $hostname;

sub hostname {
    my ($self) = @_;
    return $hostname ||= (gethostbyname(Sys::Hostname::hostname))[0];
        # Thanks to Sys::Hostname::FQDN for that trick!
}

sub ipv4_address_to_ipv6 {
    my ($self, $ipv4_address) = @_;
    UNIVERSAL::isa($ipv4_address, 'NetAddr::IP') and
    $ipv4_address->version == 4
        or throw Mail::SPF::EInvalidOptionValue('NetAddr::IP IPv4 address expected');
    return NetAddr::IP->new(
        '::ffff:' . $ipv4_address->addr,   # address
        $ipv4_address->masklen - 32 + 128  # netmask length
    );
}

sub ipv6_address_to_ipv4 {
    my ($self, $ipv6_address) = @_;
    UNIVERSAL::isa($ipv6_address, 'NetAddr::IP') and
    $ipv6_address->version == 6 and
    $ipv6_address->short =~ $self->ipv4_mapped_ipv6_address_pattern
        or throw Mail::SPF::EInvalidOptionValue('NetAddr::IP IPv4-mapped IPv6 address expected');
    return NetAddr::IP->new(
        join('.', unpack('C4', pack('H8', sprintf('%04s%04s', $1, $2)))),           # address
        $ipv6_address->masklen >= 128 - 32 ? $ipv6_address->masklen - 128 + 32 : 0  # netmask length
    );
}

sub ipv6_address_is_ipv4_mapped {
    my ($self, $ipv6_address) = @_;
    return (
        UNIVERSAL::isa($ipv6_address, 'NetAddr::IP') and
        $ipv6_address->version == 6 and
        $ipv6_address->short =~ $self->ipv4_mapped_ipv6_address_pattern
    );
}

sub ip_address_to_string {
    my ($self, $ip_address) = @_;
    UNIVERSAL::isa($ip_address, 'NetAddr::IP') and
    ($ip_address->version == 4 or $ip_address->version == 6)
        or throw Mail::SPF::EInvalidOptionValue('NetAddr::IP IPv4 or IPv6 address expected');
    return $ip_address->version == 4 ? $ip_address->addr : lc($ip_address->short);
}

sub ip_address_reverse {
    my ($self, $ip_address) = @_;
    UNIVERSAL::isa($ip_address, 'NetAddr::IP') and
    ($ip_address->version == 4 or $ip_address->version == 6)
        or throw Mail::SPF::EInvalidOptionValue('NetAddr::IP IPv4 or IPv6 address expected');
    try {
        # Treat IPv4-mapped IPv6 addresses as IPv4 addresses:
        $ip_address = $self->ipv6_address_to_ipv4($ip_address);
    }
    catch Mail::SPF::EInvalidOptionValue with {};
        # ...deliberately ignoring conversion errors.
    if ($ip_address->version == 4) {
        my @octets  = split(/\./, $ip_address->addr);
           @octets  = @octets[0 .. int($ip_address->masklen / 8) - 1];
        return join('.', reverse(@octets)) . '.in-addr.arpa.';
    }
    elsif ($ip_address->version == 6) {
        my @nibbles = split(//, unpack("H32", $ip_address->aton));
           @nibbles = @nibbles[0 .. int($ip_address->masklen / 4) - 1];
        return join('.', reverse(@nibbles)) . '.ip6.arpa.';
    }
}

use constant valid_domain_match_none        => 0;
use constant valid_domain_match_subdomain   => 1;
use constant valid_domain_match_identical   => 2;

sub valid_domain_for_ip_address {
    my ($self, $server, $request, $ip_address, $domain, $find_best_match, $accept_any_domain) = @_;
    
    my $addr_rr_type    = $ip_address->version == 4 ? 'A' : 'AAAA';
    
    my $reverse_ip_name = $self->ip_address_reverse($ip_address);
    my $ptr_packet      = $server->dns_lookup($reverse_ip_name, 'PTR');
    my @ptr_rrs         = $ptr_packet->answer
        or $server->count_void_dns_lookup($request);
    
    # Respect the PTR mechanism lookups limit (RFC 4408, 5.5/3/4):
    @ptr_rrs = splice(@ptr_rrs, 0, $server->max_name_lookups_per_ptr_mech)
        if defined($server->max_name_lookups_per_ptr_mech);
    
    my $best_match_type;
    my $valid_domain;
    
    # Check PTR records:
    foreach my $ptr_rr (@ptr_rrs) {
        if ($ptr_rr->type eq 'PTR') {
            my $ptr_domain = $ptr_rr->ptrdname;
            
            my $match_type;
            if ($ptr_domain =~ /^\Q$domain\E$/i) {
                $match_type = valid_domain_match_identical;
            }
            elsif ($ptr_domain =~ /\.\Q$domain\E$/i) {
                $match_type = valid_domain_match_subdomain;
            }
            else {
                $match_type = valid_domain_match_none;
            }
            
            # If we're not accepting _any_ domain, and the PTR domain does not match
            # the requested domain at all, ignore this PTR domain (RFC 4408, 5.5/5):
            next if not $accept_any_domain and $match_type == valid_domain_match_none;
            
            my $is_valid_domain = FALSE;
            
            try {
                my $addr_packet = $server->dns_lookup($ptr_domain, $addr_rr_type);
                my @addr_rrs    = $addr_packet->answer
                    or $server->count_void_dns_lookup($request);
                foreach my $addr_rr (@addr_rrs) {
                    if ($addr_rr->type eq $addr_rr_type) {
                        $is_valid_domain = TRUE, last
                            if $ip_address == NetAddr::IP->new($addr_rr->address);
                            # IP address reverse and forward mapping match,
                            # PTR domain validated!
                    }
                    elsif ($addr_rr->type =~ /^(CNAME|A|AAAA)$/) {
                        # A CNAME (which has hopefully been resolved by the server
                        # for us already), or an address RR of an unrequested type.
                        # Silently ignore any of those.
                        # FIXME Silently ignoring address RRs of an "unrequested"
                        # FIXME type poses a disparity with how the "ip{4,6}", "a",
                        # FIXME and "mx" mechanisms tolerantly handle alien but
                        # FIXME convertible IP address types.
                    }
                    else {
                        # Unexpected RR type.
                        # TODO Generate debug info or ignore silently.
                    }
                }
            }
            catch Mail::SPF::EDNSError with {};
                # Ignore DNS errors on doing A/AAAA RR lookups (RFC 4408, 5.5/5/5).
            
            if ($is_valid_domain) {
                # If we're not looking for the _best_ match, any acceptable validated
                # domain will do (RFC 4408, 5.5/5):
                return $ptr_domain if not $find_best_match;
                
                # Otherwise, is this PTR domain the best possible match?
                return $ptr_domain if $match_type == valid_domain_match_identical;
                
                # Lastly, record this match as the best one as of yet:
                if (
                    not defined($best_match_type) or
                    $match_type > $best_match_type
                ) {
                    $valid_domain    = $ptr_domain;
                    $best_match_type = $match_type;
                }
            }
        }
        else {
            # Unexpected RR type.
            # TODO Generate debug info or ignore silently.
        }
    }
    
    # Return best match, possibly none (undef):
    return $valid_domain;
}

TRUE;