Server IP : 85.214.239.14 / Your IP : 3.16.49.213 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /usr/share/perl5/Mail/SPF/ |
Upload File : |
# # Mail::SPF::Util # Mail::SPF utility class. # # (C) 2005-2012 Julian Mehnle <julian@mehnle.net> # 2005 Shevek <cpan@anarres.org> # $Id: Util.pm 57 2012-01-30 08:15:31Z julian $ # ############################################################################## package Mail::SPF::Util; =head1 NAME Mail::SPF::Util - Mail::SPF utility class =cut 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: ############################################################################## =head1 SYNOPSIS 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 ); $sanitized_string = Mail::SPF::Util->sanitize_string($string); =cut # Implementation: ############################################################################## =head1 DESCRIPTION B<Mail::SPF::Util> is Mail::SPF's utility class. =head2 Class methods The following class methods are provided: =over =item B<hostname>: returns I<string> Returns the fully qualified domain name (FQDN) of the local host. =cut my $hostname; sub hostname { my ($self) = @_; return $hostname ||= (gethostbyname(Sys::Hostname::hostname))[0]; # Thanks to Sys::Hostname::FQDN for that trick! } =item B<ipv4_address_to_ipv6($ipv4_address)>: returns I<NetAddr::IP>; throws I<Mail::SPF::EInvalidOptionValue> Converts the specified I<NetAddr::IP> IPv4 address into an IPv4-mapped IPv6 address. Throws a I<Mail::SPF::EInvalidOptionValue> exception if the specified IP address is not an IPv4 address. =cut 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 ); } =item B<ipv6_address_to_ipv4($ipv6_address)>: returns I<NetAddr::IP>; throws I<Mail::SPF::EInvalidOptionValue> Converts the specified I<NetAddr::IP> IPv4-mapped IPv6 address into a proper IPv4 address. Throws a I<Mail::SPF::EInvalidOptionValue> exception if the specified IP address is not an IPv4-mapped IPv6 address. =cut 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 ); } =item B<ipv6_address_is_ipv4_mapped($ipv6_address)>: returns I<boolean> Returns B<true> if the specified I<NetAddr::IP> IPv6 address is an IPv4-mapped address, B<false> otherwise. =cut 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 ); } =item B<ip_address_to_string($ip_address)>: returns I<string>; throws I<Mail::SPF::EInvalidOptionValue> Returns the given I<NetAddr::IP> IPv4 or IPv6 address compactly formatted as a I<string>. For IPv4 addresses, this is equivalent to calling L<NetAddr::IP's C<addr>|NetAddr::IP/addr> method. For IPv6 addresses, this is equivalent to calling L<NetAddr::IP's C<short>|NetAddr::IP/short> method. Throws a I<Mail::SPF::EInvalidOptionValue> exception if the specified object is not a I<NetAddr::IP> IPv4 or IPv6 address object. =cut 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); } =item B<ip_address_reverse($ip_address)>: returns I<string>; throws I<Mail::SPF::EInvalidOptionValue> Returns the C<in-addr.arpa.>/C<ip6.arpa.> reverse notation of the given I<NetAddr::IP> IPv4 or IPv6 address. Throws a I<Mail::SPF::EInvalidOptionValue> exception if the specified object is not a I<NetAddr::IP> IPv4 or IPv6 address object. =cut 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.'; } } =item B<valid_domain_for_ip_address($server, $request, $ip_address, $domain, $find_best_match = false, $accept_any_domain = false)>: returns I<string> or B<undef> Finds a valid domain name for the given I<NetAddr::IP> IP address that matches the given domain or a sub-domain thereof. A domain name is valid for the given IP address if the IP address reverse-maps to that domain name in DNS, and the domain name in turn forward-maps to the IP address. Uses the given I<Mail::SPF::Server> and I<Mail::SPF::Request> objects to perform DNS look-ups. Returns the validated domain name. If C<$find_best_match> is B<true>, the one domain name is selected that best matches the given domain name, preferring direct matches over sub-domain matches. Defaults to B<false>. If C<$accept_any_domain> is B<true>, I<any> domain names are considered acceptable, even if they differ completely from the given domain name (which is then effectively unused unless a best match is requested). Defaults to B<false>. =cut 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; } =item B<sanitize_string($string)>: returns I<string> or B<undef> Replaces all non-printable or non-ascii characters in a string with their hex-escaped representation (e.g., C<\x00>). =cut sub sanitize_string { my ($self, $string) = @_; return undef if not defined($string); $string =~ s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02x", ord($1))/gex; $string =~ s/([\x{0100}-\x{ffff}]) /sprintf("\\x{%04x}", ord($1))/gex; return $string; } =back =head1 SEE ALSO L<Mail::SPF> For availability, support, and license information, see the README file included with Mail::SPF. =head1 AUTHORS Julian Mehnle <julian@mehnle.net>, Shevek <cpan@anarres.org> =cut TRUE;