Mail::SPF::Server - Server class for processing SPF requests

    use Mail::SPF;

    my $spf_server  = Mail::SPF::Server->new(
        # Optional custom default for authority explanation:
        default_authority_explanation =>
            'See http://www.%{d}/why/id=%{S};ip=%{I};r=%{R}'
    );

    my $result      = $spf_server->process($request);

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

package Mail::SPF::Server;

use warnings;
use strict;

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

use Error ':try';
use Net::DNS::Resolver;

use Mail::SPF::MacroString;
use Mail::SPF::Record;
use Mail::SPF::Result;

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

use constant record_classes_by_version => {
    1   => 'Mail::SPF::v1::Record',
    2   => 'Mail::SPF::v2::Record'
};

use constant result_base_class => 'Mail::SPF::Result';

use constant query_rr_type_all                      => 0;
use constant query_rr_type_spf                      => 1;
use constant query_rr_type_txt                      => 2;

use constant default_default_authority_explanation  =>
    'Please see http://www.openspf.org/Why?s=%{_scope};id=%{S};ip=%{C};r=%{R}';

sub default_query_rr_types { shift->query_rr_type_all };

use constant default_max_dns_interactive_terms      => 10;  # RFC 4408, 10.1/6
use constant default_max_name_lookups_per_term      => 10;  # RFC 4408, 10.1/7
sub default_max_name_lookups_per_mx_mech  { shift->max_name_lookups_per_term };
sub default_max_name_lookups_per_ptr_mech { shift->max_name_lookups_per_term };

use constant default_max_void_dns_lookups           => 2;

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

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

sub new {
    my ($self, %options) = @_;
    $self = $self->SUPER::new(%options);
    
    $self->{default_authority_explanation} = $self->default_default_authority_explanation
        if not defined($self->{default_authority_explanation});
    $self->{default_authority_explanation} = Mail::SPF::MacroString->new(
        text            => $self->{default_authority_explanation},
        server          => $self,
        is_explanation  => TRUE
    )
        if not UNIVERSAL::isa($self->{default_authority_explanation}, 'Mail::SPF::MacroString');
    
    $self->{hostname} ||= Mail::SPF::Util->hostname;
    
    $self->{dns_resolver} ||= Net::DNS::Resolver->new();
    
    $self->{query_rr_types} = $self->default_query_rr_types
        if not defined($self->{query_rr_types});
    
    $self->{max_dns_interactive_terms}      = $self->default_max_dns_interactive_terms
                                       if not exists($self->{max_dns_interactive_terms});
    $self->{max_name_lookups_per_term}      = $self->default_max_name_lookups_per_term
                                       if not exists($self->{max_name_lookups_per_term});
    $self->{max_name_lookups_per_mx_mech}   = $self->default_max_name_lookups_per_mx_mech
                                       if not exists($self->{max_name_lookups_per_mx_mech});
    $self->{max_name_lookups_per_ptr_mech}  = $self->default_max_name_lookups_per_ptr_mech
                                       if not exists($self->{max_name_lookups_per_ptr_mech});
    
    $self->{max_void_dns_lookups}           = $self->default_max_void_dns_lookups
                                       if not exists($self->{max_void_dns_lookups});
    
    return $self;
}

sub result_class {
    my ($self, $name) = @_;
    return
        defined($name) ?
            $self->result_base_class->result_classes->{$name}
        :   $self->result_base_class;
}

sub throw_result {
    my ($self, $name, $request, @text) = @_;
    $self->result_class($name)->throw($self, $request, @text);
}

sub process {
    my ($self, $request) = @_;
    
    $request->state('authority_explanation', undef);
    $request->state('dns_interactive_terms_count', 0);
    $request->state('void_dns_lookups_count', 0);
    
    my $result;
    try {
        my $record = $self->select_record($request);
        $request->record($record);
        $record->eval($self, $request);
    }
    catch Mail::SPF::Result with {
        $result = shift;
    }
    catch Mail::SPF::EDNSError with {
        $result = $self->result_class('temperror')->new($self, $request, shift->text);
    }
    catch Mail::SPF::ENoAcceptableRecord with {
        $result = $self->result_class('none'     )->new($self, $request, shift->text);
    }
    catch Mail::SPF::ERedundantAcceptableRecords with {
        $result = $self->result_class('permerror')->new($self, $request, shift->text);
    }
    catch Mail::SPF::ESyntaxError with {
        $result = $self->result_class('permerror')->new($self, $request, shift->text);
    }
    catch Mail::SPF::EProcessingLimitExceeded with {
        $result = $self->result_class('permerror')->new($self, $request, shift->text);
    };
    # Propagate other, unknown errors.
    # This should not happen, but if it does, it helps exposing the bug!
    
    return $result;
}

sub select_record {
    my ($self, $request) = @_;
    
    my $domain   = $request->authority_domain;
    my @versions = $request->versions;
    my $scope    = $request->scope;
    
    # Employ identical behavior for 'v=spf1' and 'spf2.0' records, both of
    # which support SPF (code 99) and TXT type records (this may be different
    # in future revisions of SPF):
    # Query for SPF type records first, then fall back to TXT type records.
    
    my @records;
    my $query_count = 0;
    my @dns_errors;
    
    # Query for SPF-type RRs first:
    if (
        $self->query_rr_types == $self->query_rr_type_all or
        $self->query_rr_types &  $self->query_rr_type_spf
    ) {
        try {
            $query_count++;
            my $packet = $self->dns_lookup($domain, 'SPF');
            push(
                @records,
                $self->get_acceptable_records_from_packet(
                    $packet, 'SPF', \@versions, $scope, $domain)
            );
        }
        catch Mail::SPF::EDNSError with {
            push(@dns_errors, shift);
        };
        #catch Mail::SPF::EDNSTimeout with {
        #    # FIXME Ignore DNS time-outs on SPF type lookups?
        #    # Apparrently some brain-dead DNS servers time out on SPF-type queries.
        #};
    }
    
    # If no usable SPF-type RRs, try TXT-type RRs:
    if (
        not @records and
        (
            $self->query_rr_types == $self->query_rr_type_all or
            $self->query_rr_types &  $self->query_rr_type_txt
        )
    ) {
        # NOTE:
        #   This deliberately violates RFC 4406 (Sender ID), 4.4/3 (4.4.1):
        #   TXT-type RRs are still tried if there _are_ SPF-type RRs but all of
        #   them are inapplicable (i.e. "Hi!", or even "spf2.0/pra" for an
        #   'mfrom' scope request).  This conforms to the spirit of the more
        #   sensible algorithm in RFC 4408 (SPF), 4.5.
        #   Implication:  Sender ID processing may make use of existing TXT-
        #   type records where a result of "None" would normally be returned
        #   under a strict interpretation of RFC 4406.
        
        try {
            $query_count++;
            my $packet = $self->dns_lookup($domain, 'TXT');
            push(
                @records,
                $self->get_acceptable_records_from_packet(
                    $packet, 'TXT', \@versions, $scope, $domain)
            );
        }
        catch Mail::SPF::EDNSError with {
            push(@dns_errors, shift);
        };
    }
    
    @dns_errors < $query_count
        or $dns_errors[0]->throw;
        # Unless at least one query succeeded, re-throw the first DNS error that occurred.
    
    @records
        or throw Mail::SPF::ENoAcceptableRecord(
            "No applicable sender policy available");  # RFC 4408, 4.5/7
    
    # Discard all records but the highest acceptable version:
    my $preferred_record_class = $records[0]->class;
    @records = grep($_->isa($preferred_record_class), @records);
    
    @records == 1
        or throw Mail::SPF::ERedundantAcceptableRecords(
            "Redundant applicable '" . $preferred_record_class->version_tag . "' " .
            "sender policies found");  # RFC 4408, 4.5/6
    
    return $records[0];
}

sub get_acceptable_records_from_packet {
    my ($self, $packet, $rr_type, $versions, $scope, $domain) = @_;
    
    my @versions = sort { $b <=> $a } @$versions;
        # Try higher record versions first.
        # (This may be too simplistic for future revisions of SPF.)
    
    my @records;
    foreach my $rr ($packet->answer) {
        next if $rr->type ne $rr_type;  # Ignore RRs of unexpected type.
        
        my $text = join('', $rr->char_str_list);
        my $record;
        
        # Try to parse RR as each of the requested record versions,
        # starting from the highest version:
        VERSION:
        foreach my $version (@versions) {
            my $class = $self->record_classes_by_version->{$version};
            eval("require $class");
            try {
                $record = $class->new_from_string($text);
            }
            catch Mail::SPF::EInvalidRecordVersion with {};
                # Ignore non-SPF and unknown-version records.
                # Propagate other errors (including syntax errors), though.
            last VERSION if defined($record);
        }
        
        push(@records, $record)
            if  defined($record)
            and grep($scope eq $_, $record->scopes);  # record covers requested scope?
    }
    return @records;
}

sub dns_lookup {
    my ($self, $domain, $rr_type) = @_;
    
    if (UNIVERSAL::isa($domain, 'Mail::SPF::MacroString')) {
        $domain = $domain->expand;
        # Truncate overlong labels at 63 bytes (RFC 4408, 8.1/27):
        $domain =~ s/([^.]{63})[^.]+/$1/g;
        # Drop labels from the head of domain if longer than 253 bytes (RFC 4408, 8.1/25):
        $domain =~ s/^[^.]+\.(.*)$/$1/
            while length($domain) > 253;
    }
    
    $domain =~ s/^(.*?)\.?$/\L$1/;  # Normalize domain.
    
    my $packet = $self->dns_resolver->send($domain, $rr_type);
    
    # Throw DNS exception unless an answer packet with RCODE 0 or 3 (NXDOMAIN)
    # was received (thereby treating NXDOMAIN as an acceptable but empty answer packet):
    $self->dns_resolver->errorstring !~ /^(timeout|query timed out)$/
        or throw Mail::SPF::EDNSTimeout(
            "Time-out on DNS '$rr_type' lookup of '$domain'");
    defined($packet)
        or throw Mail::SPF::EDNSError(
            "Unknown error on DNS '$rr_type' lookup of '$domain'");
    $packet->header->rcode =~ /^(NOERROR|NXDOMAIN)$/
        or throw Mail::SPF::EDNSError(
            "'" . $packet->header->rcode . "' error on DNS '$rr_type' lookup of '$domain'");
    
    return $packet;
}

sub count_dns_interactive_term {
    my ($self, $request) = @_;
    my $dns_interactive_terms_count = ++$request->root_request->state('dns_interactive_terms_count');
    my $max_dns_interactive_terms = $self->max_dns_interactive_terms;
    if (
        defined($max_dns_interactive_terms) and
        $dns_interactive_terms_count > $max_dns_interactive_terms
    ) {
        throw Mail::SPF::EProcessingLimitExceeded(
            "Maximum DNS-interactive terms limit ($max_dns_interactive_terms) exceeded");
    }
    return;
}

sub count_void_dns_lookup {
    my ($self, $request) = @_;
    my $void_dns_lookups_count = ++$request->root_request->state('void_dns_lookups_count');
    my $max_void_dns_lookups = $self->max_void_dns_lookups;
    if (
        defined($max_void_dns_lookups) and
        $void_dns_lookups_count > $max_void_dns_lookups
    ) {
        throw Mail::SPF::EProcessingLimitExceeded(
            "Maximum void DNS look-ups limit ($max_void_dns_lookups) exceeded");
    }
    return;
}

# Make read-only accessors:
__PACKAGE__->make_accessor($_, TRUE)
    foreach qw(
        default_authority_explanation
        hostname
        
        dns_resolver
        query_rr_types
        
        max_dns_interactive_terms
        max_name_lookups_per_term
        max_name_lookups_per_mx_mech
        max_name_lookups_per_ptr_mech
        
        max_void_dns_lookups
    );

TRUE;