feat: add full Zonemaster stack with Docker and Spanish UI
- Clone all 5 Zonemaster component repos (LDNS, Engine, CLI, Backend, GUI) - Dockerfile.backend: 8-stage multi-stage build LDNS→Engine→CLI→Backend - Dockerfile.gui: Astro static build served via nginx - docker-compose.yml: backend (internal) + frontend (port 5353) - nginx.conf: root redirects to /es/, /api/ proxied to backend - zonemaster-gui/config.ts: defaultLanguage set to 'es' (Spanish) Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
432
zonemaster-engine/lib/Zonemaster/Engine.pm
Normal file
432
zonemaster-engine/lib/Zonemaster/Engine.pm
Normal file
@@ -0,0 +1,432 @@
|
||||
package Zonemaster::Engine;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v8.1.1");
|
||||
|
||||
BEGIN {
|
||||
# Locale::TextDomain (<= 1.20) doesn't know about File::ShareDir so give a helping hand.
|
||||
# This is a hugely simplified version of the reference implementation located here:
|
||||
# https://metacpan.org/source/GUIDO/libintl-perl-1.21/lib/Locale/TextDomain.pm
|
||||
require File::ShareDir;
|
||||
require Locale::TextDomain;
|
||||
my $share = File::ShareDir::dist_dir( 'Zonemaster-Engine' );
|
||||
Locale::TextDomain->import( 'Zonemaster-Engine', "$share/locale" );
|
||||
}
|
||||
|
||||
use Class::Accessor "antlers";
|
||||
use Carp;
|
||||
|
||||
use Zonemaster::Engine::Nameserver;
|
||||
use Zonemaster::Engine::Logger;
|
||||
use Zonemaster::Engine::Profile;
|
||||
use Zonemaster::Engine::Zone;
|
||||
use Zonemaster::Engine::Test;
|
||||
use Zonemaster::Engine::Recursor;
|
||||
use Zonemaster::Engine::ASNLookup;
|
||||
|
||||
INIT {
|
||||
init_engine();
|
||||
}
|
||||
|
||||
our $logger;
|
||||
our $recursor = Zonemaster::Engine::Recursor->new;
|
||||
|
||||
my $init_done = 0;
|
||||
|
||||
sub init_engine {
|
||||
return if $init_done++;
|
||||
Zonemaster::Engine::Recursor::init_recursor();
|
||||
}
|
||||
|
||||
sub logger {
|
||||
return $logger //= Zonemaster::Engine::Logger->new;
|
||||
}
|
||||
|
||||
sub profile {
|
||||
return Zonemaster::Engine::Profile->effective;
|
||||
}
|
||||
|
||||
sub ns {
|
||||
my ( $class, $name, $address ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Nameserver->new( { name => $name, address => $address } );
|
||||
}
|
||||
|
||||
sub zone {
|
||||
my ( $class, $name ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Zone->new( { name => Zonemaster::Engine::DNSName->new( $name ) } );
|
||||
}
|
||||
|
||||
sub test_zone {
|
||||
my ( $class, $zname ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Test->run_all_for( $class->zone( $zname ) );
|
||||
}
|
||||
|
||||
sub test_module {
|
||||
my ( $class, $module, $zname ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Test->run_module( $module, $class->zone( $zname ) );
|
||||
}
|
||||
|
||||
sub test_method {
|
||||
my ( $class, $module, $method, $zname ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Test->run_one( $module, $method, $class->zone( $zname ) );
|
||||
}
|
||||
|
||||
sub all_tags {
|
||||
my ( $class ) = @_;
|
||||
my @res;
|
||||
|
||||
foreach my $module ( sort { $a cmp $b } Zonemaster::Engine::Test->modules ) {
|
||||
my $full = "Zonemaster::Engine::Test::$module";
|
||||
my $ref = $full->metadata;
|
||||
foreach my $list ( values %{$ref} ) {
|
||||
push @res, map { uc( $module ) . q{:} . $_ } sort { $a cmp $b } @{$list};
|
||||
}
|
||||
}
|
||||
|
||||
return @res;
|
||||
}
|
||||
|
||||
sub all_methods {
|
||||
my ( $class ) = @_;
|
||||
my %res;
|
||||
|
||||
foreach my $module ( Zonemaster::Engine::Test->modules ) {
|
||||
my $full = "Zonemaster::Engine::Test::$module";
|
||||
my $ref = $full->metadata;
|
||||
foreach my $method ( sort { $a cmp $b } keys %{$ref} ) {
|
||||
push @{ $res{$module} }, $method;
|
||||
}
|
||||
}
|
||||
|
||||
return %res;
|
||||
}
|
||||
|
||||
sub recurse {
|
||||
my ( $class, $qname, $qtype, $qclass ) = @_;
|
||||
$qtype //= 'A';
|
||||
$qclass //= 'IN';
|
||||
|
||||
return $recursor->recurse( $qname, $qtype, $qclass );
|
||||
}
|
||||
|
||||
sub add_fake_delegation {
|
||||
my ( $class, $domain, $href, %flags ) = @_;
|
||||
my $fill_in_empty_oob_glue = exists $flags{fill_in_empty_oob_glue} ? delete $flags{fill_in_empty_oob_glue} : 1;
|
||||
croak 'Unrecognized flags: ' . join( ', ', keys %flags )
|
||||
if %flags;
|
||||
undef %flags;
|
||||
|
||||
# Validate arguments
|
||||
$domain =~ /[^.]$|^\.$/
|
||||
or croak 'Argument $domain must omit the trailing dot, or it must be a single dot';
|
||||
foreach my $name ( keys %{$href} ) {
|
||||
$name =~ /[^.]$|^\.$/
|
||||
or croak 'Each key of argument $href must omit the trailing dot, or it must be a single dot';
|
||||
( !defined $href->{$name} or ref $href->{$name} eq 'ARRAY' )
|
||||
or croak 'Each value of argument $href must be an arrayref or undef';
|
||||
$href->{$name} //= []; # normalize undef to empty arrayref
|
||||
}
|
||||
|
||||
# Check fake delegation
|
||||
my $incomplete_delegation;
|
||||
if ( $fill_in_empty_oob_glue ) {
|
||||
foreach my $name ( keys %{$href} ) {
|
||||
if ( !@{ $href->{$name} }
|
||||
&& !$class->zone( $domain )->is_in_zone( $name ) )
|
||||
{
|
||||
my @ips = map { $_->ip } Zonemaster::Engine::Recursor->get_addresses_for( $name );
|
||||
push @{ $href->{$name} }, @ips;
|
||||
if ( !@ips ) {
|
||||
$incomplete_delegation = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
foreach my $name ( keys %{$href} ) {
|
||||
if ( not @{ $href->{$name} } ) {
|
||||
if ( $class->zone( $domain )->is_in_zone( $name ) ) {
|
||||
Zonemaster::Engine->logger->add( #
|
||||
FAKE_DELEGATION_IN_ZONE_NO_IP => { domain => $domain, nsname => $name }
|
||||
);
|
||||
}
|
||||
else {
|
||||
Zonemaster::Engine->logger->add( #
|
||||
FAKE_DELEGATION_NO_IP => { domain => $domain, nsname => $name }
|
||||
);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$recursor->add_fake_addresses( $domain, $href );
|
||||
my $parent = $class->zone( $recursor->parent( $domain ) );
|
||||
foreach my $ns ( @{ $parent->ns } ) {
|
||||
$ns->add_fake_delegation( $domain => $href );
|
||||
}
|
||||
|
||||
if ( $incomplete_delegation ) {
|
||||
return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_fake_ds {
|
||||
my ( $class, $domain, $aref ) = @_;
|
||||
|
||||
my $parent = $class->zone( scalar( $recursor->parent( $domain ) ) );
|
||||
if ( not $parent ) {
|
||||
die "Failed to find parent for $domain";
|
||||
}
|
||||
|
||||
foreach my $ns ( @{ $parent->ns } ) {
|
||||
$ns->add_fake_ds( $domain => $aref );
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub can_continue {
|
||||
my ( $class ) = @_;
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub save_cache {
|
||||
my ( $class, $filename ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Nameserver->save( $filename );
|
||||
}
|
||||
|
||||
sub preload_cache {
|
||||
my ( $class, $filename ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Nameserver->restore( $filename );
|
||||
}
|
||||
|
||||
sub asn_lookup {
|
||||
my ( undef, $ip ) = @_;
|
||||
|
||||
return Zonemaster::Engine::ASNLookup->get( $ip );
|
||||
}
|
||||
|
||||
sub modules {
|
||||
return Zonemaster::Engine::Test->modules;
|
||||
}
|
||||
|
||||
sub start_time_now {
|
||||
Zonemaster::Engine::Logger->start_time_now();
|
||||
return;
|
||||
}
|
||||
|
||||
sub reset {
|
||||
Zonemaster::Engine::Logger->start_time_now();
|
||||
Zonemaster::Engine::Logger->reset_config();
|
||||
Zonemaster::Engine::Nameserver->empty_cache();
|
||||
$logger->clear_history() if $logger;
|
||||
Zonemaster::Engine::Recursor->clear_cache();
|
||||
Zonemaster::Engine::TestMethodsV2->clear_cache();
|
||||
return;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine - A tool to check the quality of a DNS zone
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @results = Zonemaster::Engine->test_zone('iis.se')
|
||||
|
||||
=head1 INTRODUCTION
|
||||
|
||||
This manual describes the main L<Zonemaster::Engine> module. If what you're after is documentation on the Zonemaster test engine as a whole, see L<Zonemaster::Engine::Overview>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item init_engine()
|
||||
|
||||
Run the initialization tasks if they have not been run already. This method is called automatically in INIT block.
|
||||
|
||||
=item test_zone($name)
|
||||
|
||||
Runs all available tests and returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=item test_module($module, $name)
|
||||
|
||||
Runs all available tests for the zone with the given name in the specified module.
|
||||
|
||||
=item test_method($module, $method, $name)
|
||||
|
||||
Run one particular test method in one particular module for one particular zone.
|
||||
The requested module must be in the list of currently enabled modules (that is,
|
||||
not a module disabled by the current profile), and the method must be listed in
|
||||
the metadata of the module exports.
|
||||
If those requirements are fulfilled, the method will be called with the provided
|
||||
arguments.
|
||||
|
||||
=item zone($name)
|
||||
|
||||
Returns a L<Zonemaster::Engine::Zone> object for the given name.
|
||||
|
||||
=item ns($name, $address)
|
||||
|
||||
Returns a L<Zonemaster::Engine::Nameserver> object for the given name and address.
|
||||
|
||||
=item profile()
|
||||
|
||||
Returns the effective profile (L<Zonemaster::Engine::Profile> object).
|
||||
|
||||
=item logger()
|
||||
|
||||
Returns the global L<Zonemaster::Engine::Logger> object.
|
||||
|
||||
=item all_tags()
|
||||
|
||||
Returns a list of all the tags that can be logged for all available test modules.
|
||||
|
||||
=item all_methods()
|
||||
|
||||
Returns a hash, where the keys are test module names and the values are lists with the names of the test methods in that module.
|
||||
|
||||
=item recurse($name, $type, $class)
|
||||
|
||||
Does a recursive lookup for the given name, type and class, and returns the resulting packet (if any). Simply calls
|
||||
L<Zonemaster::Engine::Recursor/recurse> on a globally stored object.
|
||||
|
||||
=item can_continue()
|
||||
|
||||
In case of critical condition that prevents tool to process tests, add test here and return False.
|
||||
|
||||
=item save_cache($filename)
|
||||
|
||||
After running the tests, save the accumulated cache to a file with the given name.
|
||||
|
||||
=item preload_cache($filename)
|
||||
|
||||
Before running the tests, load the cache with information from a file with the given name. This file must have the same format as is produced by
|
||||
L</save_cache()>.
|
||||
|
||||
=item asn_lookup($ip)
|
||||
|
||||
Takes a single IP address (string or L<Net::IP::XS> object) and returns a list of AS numbers, if any.
|
||||
|
||||
=item modules()
|
||||
|
||||
Returns a list of the loaded test modules. Exactly the same as L<Zonemaster::Engine::Test/modules>.
|
||||
|
||||
=item add_fake_delegation($domain, $data, %flags)
|
||||
|
||||
This method adds some fake delegation information to the system.
|
||||
|
||||
The arguments are a domain name, and a hashref with delegation information.
|
||||
The keys in the hash are nameserver names, and the values are arrayrefs of IP
|
||||
addresses for their corresponding nameserver.
|
||||
Alternatively the IP addresses may be specified as an `undef` which is handled
|
||||
the same as an empty arrayref.
|
||||
|
||||
For each provided nameserver with an empty list of addresses, either a
|
||||
C<FAKE_DELEGATION_NO_IP> or a C<FAKE_DELEGATION_IN_ZONE_NO_IP> message is
|
||||
emitted.
|
||||
|
||||
The only recognized flag is C<fill_in_empty_oob_glue>.
|
||||
This flag is boolean and defaults to true.
|
||||
If this flag is true, this method updates the given C<$data> by looking up and
|
||||
filling in some glue addresses.
|
||||
Specifically the glue addresses for any nameserver name that are
|
||||
out-of-bailiwick of the given C<$domain> and that comes with an empty list of
|
||||
addresses.
|
||||
|
||||
Returns `1` if all name servers in C<$data> have non-empty lists of
|
||||
glue (after they've been filled in) or if `fill_in_empty_oob_glue` is false.
|
||||
Otherwise it returns `undef`.
|
||||
|
||||
Examples:
|
||||
|
||||
Zonemaster::Engine->add_fake_delegation(
|
||||
'lysator.liu.se' => {
|
||||
'ns1.nic.fr' => [ ],
|
||||
'ns.nic.se' => [ '212.247.7.228', '2a00:801:f0:53::53' ],
|
||||
'i.ns.se' => [ '194.146.106.22', '2001:67c:1010:5::53' ],
|
||||
'ns3.nic.se' => [ '212.247.8.152', '2a00:801:f0:211::152' ]
|
||||
},
|
||||
);
|
||||
|
||||
returns 1.
|
||||
|
||||
Zonemaster::Engine->add_fake_delegation(
|
||||
'lysator.liu.se' => {
|
||||
'ns1.lysator.liu.se' => [ ],
|
||||
'ns.nic.se' => [ '212.247.7.228', '2a00:801:f0:53::53' ],
|
||||
'i.ns.se' => [ '194.146.106.22', '2001:67c:1010:5::53' ],
|
||||
'ns3.nic.se' => [ '212.247.8.152', '2a00:801:f0:211::152' ]
|
||||
}
|
||||
);
|
||||
|
||||
returns C<undef> (signalling that fake delegation with empty glue was added to
|
||||
the system).
|
||||
|
||||
Zonemaster::Engine->add_fake_delegation(
|
||||
'lysator.liu.se' => {
|
||||
'ns1.nic.fr' => [ ],
|
||||
'ns.nic.se' => [ '212.247.7.228', '2a00:801:f0:53::53' ],
|
||||
'i.ns.se' => [ '194.146.106.22', '2001:67c:1010:5::53' ],
|
||||
'ns3.nic.se' => [ '212.247.8.152', '2a00:801:f0:211::152' ]
|
||||
},
|
||||
fill_in_empty_oob_glue => 0,
|
||||
);
|
||||
|
||||
returns 1. It does not even attempt to fill in glue for ns1.nic.fr.
|
||||
|
||||
=item add_fake_ds($domain, $data)
|
||||
|
||||
This method adds fake DS records to the system. The arguments are a domain
|
||||
name, and a reference to a list of references to hashes. The hashes in turn
|
||||
must have the keys C<keytag>, C<algorithm>, C<type> and C<digest>, with the
|
||||
values holding the corresponding data. The digest data should be a single
|
||||
unbroken string of hexadecimal digits.
|
||||
|
||||
Example:
|
||||
|
||||
Zonemaster::Engine->add_fake_ds(
|
||||
'nic.se' => [
|
||||
{ keytag => 16696, algorithm => 5, type => 2, digest => '40079DDF8D09E7F10BB248A69B6630478A28EF969DDE399F95BC3B39F8CBACD7' },
|
||||
{ keytag => 16696, algorithm => 5, type => 1, digest => 'EF5D421412A5EAF1230071AFFD4F585E3B2B1A60' },
|
||||
]
|
||||
);
|
||||
|
||||
=item start_time_now()
|
||||
|
||||
Set the logger's start time to the current time.
|
||||
|
||||
=item reset()
|
||||
|
||||
Reset logger start time to current time, empty the list of log messages, clear
|
||||
nameserver object cache, clear recursor cache and clear all cached results of
|
||||
MethodsV2.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Vincent Levigneron <vincent.levigneron at nic.fr>
|
||||
- Current maintainer
|
||||
|
||||
Calle Dybedahl <calle at init.se>
|
||||
- Original author
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This is free software under a 2-clause BSD license. The full text of the license can
|
||||
be found in the F<LICENSE> file included with this distribution.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
238
zonemaster-engine/lib/Zonemaster/Engine/ASNLookup.pm
Normal file
238
zonemaster-engine/lib/Zonemaster/Engine/ASNLookup.pm
Normal file
@@ -0,0 +1,238 @@
|
||||
package Zonemaster::Engine::ASNLookup;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare( "v1.0.11" );
|
||||
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::Engine::Util qw( name );
|
||||
use Zonemaster::Engine::Nameserver;
|
||||
use Zonemaster::Engine::Profile;
|
||||
|
||||
use IO::Socket;
|
||||
use IO::Socket::INET;
|
||||
use Net::IP::XS;
|
||||
use Scalar::Util qw( looks_like_number );
|
||||
|
||||
our @db_sources;
|
||||
our $db_style;
|
||||
|
||||
sub get_with_prefix {
|
||||
my ( $class, $ip ) = @_;
|
||||
|
||||
if ( not @db_sources ) {
|
||||
$db_style = Zonemaster::Engine::Profile->effective->get( q{asn_db.style} );
|
||||
my %db_sources = %{ Zonemaster::Engine::Profile->effective->get( q{asn_db.sources} ) };
|
||||
@db_sources = map { name( $_ ) } @{ $db_sources{ $db_style } };
|
||||
}
|
||||
|
||||
if ( not ref( $ip ) or not $ip->isa( 'Net::IP::XS' ) ) {
|
||||
$ip = Net::IP::XS->new( $ip );
|
||||
}
|
||||
|
||||
if ( not @db_sources ) {
|
||||
die "ASN database sources undefined";
|
||||
}
|
||||
|
||||
my ( $asnref, $prefix, $raw, $ret_code );
|
||||
|
||||
if ( $db_style eq q{cymru} ) {
|
||||
( $asnref, $prefix, $raw, $ret_code ) = _cymru_asn_lookup($ip);
|
||||
}
|
||||
elsif ( $db_style eq q{ripe} ) {
|
||||
( $asnref, $prefix, $raw, $ret_code ) = _ripe_asn_lookup($ip);
|
||||
}
|
||||
else {
|
||||
if ( not $db_style ) {
|
||||
die "ASN database style undefined";
|
||||
}
|
||||
else {
|
||||
die "ASN database style value '$db_style' is illegal";
|
||||
}
|
||||
}
|
||||
|
||||
map { looks_like_number( $_ ) || die "ASN lookup value isn't numeric: '$_'" } @$asnref;
|
||||
|
||||
return ( $asnref, $prefix, $raw, $ret_code );
|
||||
|
||||
} ## end sub get_with_prefix
|
||||
|
||||
sub _cymru_asn_lookup {
|
||||
my $ip = shift;
|
||||
my @asns = ();
|
||||
|
||||
my $db_source_nb = 0;
|
||||
foreach my $db_source ( @db_sources ) {
|
||||
Zonemaster::Engine->logger->add( ASN_LOOKUP_SOURCE => { name => $db_source } );
|
||||
my $reverse = $ip->reverse_ip;
|
||||
my $domain = $db_source->string;
|
||||
my $pair = {
|
||||
'in-addr.arpa.' => "origin.$domain",
|
||||
'ip6.arpa.' => "origin6.$domain",
|
||||
};
|
||||
$db_source_nb++;
|
||||
|
||||
foreach my $root ( keys %{$pair} ) {
|
||||
if ( $reverse =~ s/$root/$pair->{$root}/ix ) {
|
||||
my $p = Zonemaster::Engine->recurse( $reverse, 'TXT' );
|
||||
|
||||
if ( $p ) {
|
||||
if ( $p->rcode eq q{NXDOMAIN} ) {
|
||||
if ( $p->get_records( 'SOA', 'authority' ) and scalar $p->get_records( 'SOA', 'authority' ) == 1 and ($p->get_records( 'SOA', 'authority' ))[0]->owner eq name( $db_source ) ) {
|
||||
return \@asns, undef, q{}, q{EMPTY_ASN_SET};
|
||||
}
|
||||
}
|
||||
elsif ( $p->rcode eq q{NOERROR} ) {
|
||||
if ( $p->answer ) {
|
||||
my @rr = $p->get_records( 'TXT', 'answer' );
|
||||
|
||||
if ( @rr ) {
|
||||
my $max_length = 0;
|
||||
my @fields;
|
||||
my $str;
|
||||
|
||||
foreach my $rr ( @rr ) {
|
||||
my $_str = $rr->txtdata;
|
||||
my @_fields = split( /[ ][|][ ]?/x, $_str );
|
||||
|
||||
next if scalar @_fields <= 1;
|
||||
return \@asns, undef, q{}, q{ERROR_ASN_DATABASE} unless Net::IP::XS->new( $_fields[1] )->overlaps( $ip );
|
||||
|
||||
my @_asns = split( /\s+/x, $_fields[0] );
|
||||
my $_prefix_length = ($_fields[1] =~ m!^.*[/](.*)!x)[0];
|
||||
if ( $_prefix_length > $max_length ) {
|
||||
$str = $_str;
|
||||
@asns = @_asns;
|
||||
@fields = @_fields;
|
||||
$max_length = $_prefix_length;
|
||||
}
|
||||
}
|
||||
|
||||
if ( @fields ) {
|
||||
if ( Net::IP::XS->new( $fields[1] )->overlaps( $ip ) ) {
|
||||
return \@asns, Net::IP::XS->new( $fields[1] ), $str, q{AS_FOUND}
|
||||
}
|
||||
}
|
||||
else {
|
||||
return \@asns, undef, q{}, q{EMPTY_ASN_SET};
|
||||
}
|
||||
}
|
||||
|
||||
return \@asns, undef, q{}, q{ERROR_ASN_DATABASE};
|
||||
}
|
||||
|
||||
return \@asns, undef, q{}, q{EMPTY_ASN_SET};
|
||||
}
|
||||
}
|
||||
|
||||
if ( $db_source_nb == scalar @db_sources ) {
|
||||
return \@asns, undef, q{}, q{ERROR_ASN_DATABASE};
|
||||
}
|
||||
|
||||
last;
|
||||
}
|
||||
}
|
||||
} ## end foreach my $db_source ( @db_sources )
|
||||
return;
|
||||
}
|
||||
|
||||
sub _ripe_asn_lookup {
|
||||
my $ip = shift;
|
||||
my @asns = ();
|
||||
|
||||
my $db_source_nb = 0;
|
||||
foreach my $db_source ( @db_sources ) {
|
||||
$db_source_nb++;
|
||||
my $socket = IO::Socket::INET->new( PeerAddr => $db_source->string,
|
||||
PeerPort => q{43},
|
||||
Proto => q{tcp} );
|
||||
unless ( $socket ) {
|
||||
if ( $db_source_nb == scalar @db_sources ) {
|
||||
return \@asns, undef, q{}, q{ERROR_ASN_DATABASE};
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
};
|
||||
|
||||
printf $socket "-F -M %s\n", $ip->short();
|
||||
|
||||
my $data;
|
||||
my $str;
|
||||
my $has_answer = 0;
|
||||
while ( defined ($data = <$socket>) ) {
|
||||
$has_answer = 1;
|
||||
chop $data;
|
||||
if ( $data !~ /^%/x and $data !~ /^\s*$/x ) {
|
||||
$str = $data;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$socket->close();
|
||||
if ( not $has_answer ) {
|
||||
if ( $db_source_nb == scalar @db_sources ) {
|
||||
return \@asns, undef, q{}, q{ERROR_ASN_DATABASE};
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif ( $str ) {
|
||||
my @fields = split( /\s+/x, $str );
|
||||
my @asns = split( '/', $fields[0] );
|
||||
return \@asns, Net::IP::XS->new( $fields[1] ), $str, q{AS_FOUND};
|
||||
}
|
||||
else {
|
||||
return \@asns, undef, q{}, q{EMPTY_ASN_SET};
|
||||
}
|
||||
} ## end foreach my $db_source ( @
|
||||
return;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my ( $class, $ip ) = @_;
|
||||
|
||||
my ( $asnref, $prefix, $raw, $ret_code ) = $class->get_with_prefix( $ip );
|
||||
|
||||
if ( $asnref ) {
|
||||
return @{$asnref};
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::ASNLookup - do lookups of ASNs for IP addresses
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my ( $asnref, $prefix, $raw, $ret_code ) = Zonemaster::Engine::ASNLookup->get_with_prefix( '8.8.4.4' );
|
||||
my $asnref = Zonemaster::Engine::ASNLookup->get( '192.168.0.1' );
|
||||
|
||||
=head1 FUNCTION
|
||||
|
||||
=over
|
||||
|
||||
=item get($addr)
|
||||
|
||||
As L<get_with_prefix()>, except it returns only the list of AS numbers
|
||||
for the address, if any.
|
||||
|
||||
=item get_with_prefix($addr)
|
||||
|
||||
Takes a string (or a L<Net::IP::XS> object) with a single IP address, and
|
||||
does a lookup in either: a) Cymru-style DNS zone or b) RIPE whois server,
|
||||
depending on L<Zonemaster::Engine::Profile> setting "asn_db{style}".
|
||||
|
||||
Returns a list of a reference to a list of AS numbers, a Net::IP::XS object
|
||||
of the covering prefix for that AS, a string of the raw query, and a string
|
||||
of the return code for that query.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
292
zonemaster-engine/lib/Zonemaster/Engine/Constants.pm
Normal file
292
zonemaster-engine/lib/Zonemaster/Engine/Constants.pm
Normal file
@@ -0,0 +1,292 @@
|
||||
package Zonemaster::Engine::Constants;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.2.5");
|
||||
|
||||
use Carp;
|
||||
use English qw( -no_match_vars ) ;
|
||||
use parent 'Exporter';
|
||||
use Net::IP::XS;
|
||||
use Text::CSV;
|
||||
use File::ShareDir qw[dist_dir dist_file];
|
||||
|
||||
use Readonly;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Constants - module holding constants used in Test modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Zonemaster::Engine::Constants ':all';
|
||||
|
||||
=head1 EXPORTED GROUPS
|
||||
|
||||
=over
|
||||
|
||||
=item all
|
||||
|
||||
All exportable names.
|
||||
|
||||
=item algo
|
||||
|
||||
DNSSEC algorithms.
|
||||
|
||||
=item cname
|
||||
|
||||
CNAME records.
|
||||
|
||||
=item name
|
||||
|
||||
Label and name lengths.
|
||||
|
||||
=item ip
|
||||
|
||||
IP version constants.
|
||||
|
||||
=item soa
|
||||
|
||||
SOA values limits.
|
||||
|
||||
=item misc
|
||||
|
||||
Other, uncategorized export names, e.g. UDP payload limit and minimum number of name servers per zone.
|
||||
|
||||
=item addresses
|
||||
|
||||
Address classes for IPv4 and IPv6.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
our @EXPORT_OK = qw[
|
||||
$ALGO_STATUS_DEPRECATED
|
||||
$ALGO_STATUS_PRIVATE
|
||||
$ALGO_STATUS_RESERVED
|
||||
$ALGO_STATUS_UNASSIGNED
|
||||
$ALGO_STATUS_OTHER
|
||||
$ALGO_STATUS_NOT_RECOMMENDED
|
||||
$ALGO_STATUS_NOT_ZONE_SIGN
|
||||
$BLACKLISTING_ENABLED
|
||||
$CNAME_MAX_CHAIN_LENGTH
|
||||
$CNAME_MAX_RECORDS
|
||||
$DURATION_5_MINUTES_IN_SECONDS
|
||||
$DURATION_1_HOUR_IN_SECONDS
|
||||
$DURATION_4_HOURS_IN_SECONDS
|
||||
$DURATION_12_HOURS_IN_SECONDS
|
||||
$DURATION_1_DAY_IN_SECONDS
|
||||
$DURATION_1_WEEK_IN_SECONDS
|
||||
$DURATION_180_DAYS_IN_SECONDS
|
||||
$FQDN_MAX_LENGTH
|
||||
$IP_VERSION_4
|
||||
$IP_VERSION_6
|
||||
$LABEL_MAX_LENGTH
|
||||
$SERIAL_BITS
|
||||
$SERIAL_MAX_VARIATION
|
||||
$MINIMUM_NUMBER_OF_NAMESERVERS
|
||||
$UDP_PAYLOAD_LIMIT
|
||||
$EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT
|
||||
$EDNS_UDP_PAYLOAD_DEFAULT
|
||||
$EDNS_UDP_PAYLOAD_COMMON_LIMIT
|
||||
@IPV4_SPECIAL_ADDRESSES
|
||||
@IPV6_SPECIAL_ADDRESSES
|
||||
];
|
||||
|
||||
our %EXPORT_TAGS = (
|
||||
all => \@EXPORT_OK,
|
||||
algo => [
|
||||
qw($ALGO_STATUS_DEPRECATED $ALGO_STATUS_PRIVATE $ALGO_STATUS_RESERVED $ALGO_STATUS_UNASSIGNED $ALGO_STATUS_OTHER $ALGO_STATUS_NOT_ZONE_SIGN $ALGO_STATUS_NOT_RECOMMENDED)
|
||||
],
|
||||
cname => [ qw($CNAME_MAX_CHAIN_LENGTH $CNAME_MAX_RECORDS) ],
|
||||
name => [qw($FQDN_MAX_LENGTH $LABEL_MAX_LENGTH)],
|
||||
ip => [qw($IP_VERSION_4 $IP_VERSION_6)],
|
||||
soa => [
|
||||
qw($DURATION_5_MINUTES_IN_SECONDS $DURATION_1_HOUR_IN_SECONDS $DURATION_4_HOURS_IN_SECONDS $DURATION_12_HOURS_IN_SECONDS $DURATION_1_DAY_IN_SECONDS $DURATION_1_WEEK_IN_SECONDS $DURATION_180_DAYS_IN_SECONDS $SERIAL_BITS $SERIAL_MAX_VARIATION)
|
||||
],
|
||||
misc => [qw($UDP_PAYLOAD_LIMIT $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT $EDNS_UDP_PAYLOAD_DEFAULT $EDNS_UDP_PAYLOAD_COMMON_LIMIT $MINIMUM_NUMBER_OF_NAMESERVERS $BLACKLISTING_ENABLED)]
|
||||
, # everything in %EXPORT_OK that isn't included in any of the other tags
|
||||
addresses => [qw(@IPV4_SPECIAL_ADDRESSES @IPV6_SPECIAL_ADDRESSES)],
|
||||
);
|
||||
|
||||
=head1 EXPORTED NAMES
|
||||
|
||||
=over
|
||||
|
||||
=item * C<$ALGO_STATUS_DEPRECATED>
|
||||
|
||||
=item * C<$ALGO_STATUS_PRIVATE>
|
||||
|
||||
=item * C<$ALGO_STATUS_RESERVED>
|
||||
|
||||
=item * C<$ALGO_STATUS_UNASSIGNED>
|
||||
|
||||
=item * C<$ALGO_STATUS_OTHER>
|
||||
|
||||
=item * C<$ALGO_STATUS_NOT_RECOMMENDED>
|
||||
|
||||
=item * C<$ALGO_STATUS_NOT_ZONE_SIGN>
|
||||
|
||||
=item * C<$BLACKLISTING_ENABLED>
|
||||
|
||||
A boolean, used to enable the name server blacklisting mechanism.
|
||||
|
||||
=item * C<$CNAME_MAX_CHAIN_LENGTH>
|
||||
|
||||
An integer, used to define the maximum length of a CNAME chain when doing consecutive recursive lookups.
|
||||
|
||||
=item * C<$CNAME_MAX_RECORDS>
|
||||
|
||||
An integer, used to define the maximum number of CNAME records in a response.
|
||||
|
||||
=item * C<$DURATION_5_MINUTES_IN_SECONDS>
|
||||
|
||||
=item * C<$DURATION_1_HOUR_IN_SECONDS>
|
||||
|
||||
=item * C<$DURATION_4_HOURS_IN_SECONDS>
|
||||
|
||||
=item * C<$DURATION_12_HOURS_IN_SECONDS>
|
||||
|
||||
=item * C<$DURATION_1_DAY_IN_SECONDS>
|
||||
|
||||
=item * C<$DURATION_1_WEEK_IN_SECONDS>
|
||||
|
||||
=item * C<$DURATION_180_DAYS_IN_SECONDS>
|
||||
|
||||
=item * C<$FQDN_MAX_LENGTH>
|
||||
|
||||
=item * C<$LABEL_MAX_LENGTH>
|
||||
|
||||
=item * C<$IP_VERSION_4>
|
||||
|
||||
=item * C<$IP_VERSION_6>
|
||||
|
||||
=item * C<$SERIAL_BITS>
|
||||
|
||||
An integer, used to define the size of the serial number space, as defined in RFC1982, section 2.
|
||||
|
||||
=item * C<$SERIAL_MAX_VARIATION>
|
||||
|
||||
=item * C<$MINIMUM_NUMBER_OF_NAMESERVERS>
|
||||
|
||||
=item * C<$UDP_PAYLOAD_LIMIT>
|
||||
|
||||
=item * C<$EDNS_UDP_PAYLOAD_DEFAULT>
|
||||
|
||||
An integer, used to define the EDNS0 UDP packet size in non-DNSSEC EDNS queries.
|
||||
|
||||
=item * C<$EDNS_UDP_PAYLOAD_COMMON_LIMIT>
|
||||
|
||||
=item * C<$EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT>
|
||||
|
||||
An integer, used to define the EDNS0 UDP packet size in DNSSEC queries.
|
||||
|
||||
=item * C<@IPV4_SPECIAL_ADDRESSES>
|
||||
|
||||
=item * C<@IPV6_SPECIAL_ADDRESSES>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
Readonly our $ALGO_STATUS_DEPRECATED => 1;
|
||||
Readonly our $ALGO_STATUS_PRIVATE => 4;
|
||||
Readonly our $ALGO_STATUS_RESERVED => 2;
|
||||
Readonly our $ALGO_STATUS_UNASSIGNED => 3;
|
||||
Readonly our $ALGO_STATUS_OTHER => 5;
|
||||
Readonly our $ALGO_STATUS_NOT_ZONE_SIGN => 8;
|
||||
Readonly our $ALGO_STATUS_NOT_RECOMMENDED => 9;
|
||||
|
||||
Readonly our $BLACKLISTING_ENABLED => 1;
|
||||
|
||||
Readonly our $CNAME_MAX_CHAIN_LENGTH => 10;
|
||||
Readonly our $CNAME_MAX_RECORDS => 9;
|
||||
|
||||
Readonly our $DURATION_5_MINUTES_IN_SECONDS => 5 * 60;
|
||||
Readonly our $DURATION_1_HOUR_IN_SECONDS => 60 * 60;
|
||||
Readonly our $DURATION_4_HOURS_IN_SECONDS => 4 * 60 * 60;
|
||||
Readonly our $DURATION_12_HOURS_IN_SECONDS => 12 * 60 * 60;
|
||||
Readonly our $DURATION_1_DAY_IN_SECONDS => 24 * 60 * 60;
|
||||
Readonly our $DURATION_1_WEEK_IN_SECONDS => 7 * 24 * 60 * 60;
|
||||
Readonly our $DURATION_180_DAYS_IN_SECONDS => 180 * 24 * 60 * 60;
|
||||
|
||||
# Maximum length of ASCII version of a domain name, with trailing dot.
|
||||
Readonly our $FQDN_MAX_LENGTH => 254;
|
||||
Readonly our $LABEL_MAX_LENGTH => 63;
|
||||
|
||||
Readonly our $IP_VERSION_4 => 4;
|
||||
Readonly our $IP_VERSION_6 => 6;
|
||||
|
||||
Readonly our $MINIMUM_NUMBER_OF_NAMESERVERS => 2;
|
||||
|
||||
Readonly our $SERIAL_BITS => 32;
|
||||
Readonly our $SERIAL_MAX_VARIATION => 0;
|
||||
|
||||
Readonly our $UDP_PAYLOAD_LIMIT => 512;
|
||||
Readonly our $EDNS_UDP_PAYLOAD_DEFAULT => 512;
|
||||
Readonly our $EDNS_UDP_PAYLOAD_COMMON_LIMIT => 4096;
|
||||
Readonly our $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT => 1232;
|
||||
|
||||
Readonly::Array our @IPV4_SPECIAL_ADDRESSES => _extract_iana_ip_blocks($IP_VERSION_4);
|
||||
Readonly::Array our @IPV6_SPECIAL_ADDRESSES => _extract_iana_ip_blocks($IP_VERSION_6);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item _extract_iana_ip_blocks()
|
||||
|
||||
my @array = _extract_iana_ip_blocks( $ip_version );
|
||||
|
||||
Internal method that is used to extract IP blocks details from IANA files for a given IP version (i.e. 4 or 6).
|
||||
|
||||
Takes an integer (IP version).
|
||||
|
||||
Returns a list of hashes - the keys of which are C<ip> (L<Net::IP::XS> object), C<name> (string), C<reference> (string)
|
||||
and C<globally_reachable> (string).
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _extract_iana_ip_blocks {
|
||||
my $ip_version = shift;
|
||||
my @list = ();
|
||||
|
||||
my $csv = Text::CSV->new ({
|
||||
binary => 1,
|
||||
auto_diag => 1,
|
||||
sep_char => q{,}
|
||||
});
|
||||
my @files_details = (
|
||||
{ name => q{iana-ipv4-special-registry.csv}, ip_version => $IP_VERSION_4 },
|
||||
{ name => q{iana-ipv6-special-registry.csv}, ip_version => $IP_VERSION_6 },
|
||||
);
|
||||
|
||||
foreach my $file_details ( @files_details ) {
|
||||
my $first_line = 1;
|
||||
next if ${$file_details}{ip_version} != $ip_version;
|
||||
my $makefile_name = 'Zonemaster-Engine'; # This must be the same name as "name" in Makefile.PL
|
||||
my $data_location = dist_file($makefile_name, ${$file_details}{name});
|
||||
open(my $data, '<:encoding(utf8)', $data_location) or croak "Cannot open '${data_location}' : ${OS_ERROR}";
|
||||
while (my $fields = $csv->getline( $data )) {
|
||||
if ( $first_line ) {
|
||||
$first_line = 0;
|
||||
next;
|
||||
}
|
||||
my $address_data = $fields->[0];
|
||||
$address_data =~ s/[ ]+//smx;
|
||||
foreach my $address_item ( split /,/smx, $address_data ) {
|
||||
$address_item =~ s/(\A.+\/\d+).*\z/$1/smx;
|
||||
push @list, { ip => Net::IP::XS->new( $address_item ), name => $fields->[1], reference => $fields->[2], globally_reachable => $fields->[8] };
|
||||
}
|
||||
}
|
||||
close $data or croak "Cannot close '${data_location}' : ${OS_ERROR}";
|
||||
}
|
||||
|
||||
return @list;
|
||||
} ## end sub _extract_iana_ip_blocks
|
||||
|
||||
1;
|
||||
249
zonemaster-engine/lib/Zonemaster/Engine/DNSName.pm
Normal file
249
zonemaster-engine/lib/Zonemaster/Engine/DNSName.pm
Normal file
@@ -0,0 +1,249 @@
|
||||
package Zonemaster::Engine::DNSName;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.3");
|
||||
|
||||
use Carp;
|
||||
use Scalar::Util qw( blessed );
|
||||
|
||||
use Class::Accessor "antlers";
|
||||
|
||||
use overload
|
||||
'""' => \&string,
|
||||
'cmp' => \&str_cmp;
|
||||
|
||||
has 'labels' => ( is => 'ro' );
|
||||
|
||||
sub from_string {
|
||||
my ( $class, $domain ) = @_;
|
||||
|
||||
confess 'Argument must be a string: $domain'
|
||||
if !defined $domain || ref $domain ne '';
|
||||
|
||||
my $obj = Class::Accessor::new( $class, { labels => [ split( /[.]/x, $domain ) ] } );
|
||||
|
||||
# We have the raw string, so we can precompute the string representation
|
||||
# easily and cheaply so it can be immediately returned by the string()
|
||||
# method instead of recomputing it from the labels list. The only thing we
|
||||
# need to do is to remove any trailing dot except if it’s the only
|
||||
# character.
|
||||
$obj->{_string} = ( $domain =~ s/.\K [.] \z//rx );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my ( $class, $input ) = @_;
|
||||
|
||||
my $attrs = {};
|
||||
if ( !defined $input ) {
|
||||
$attrs->{labels} = [];
|
||||
}
|
||||
elsif ( blessed $input && $input->isa( 'Zonemaster::Engine::DNSName' ) ) {
|
||||
$attrs->{labels} = \@{ $input->labels };
|
||||
}
|
||||
elsif ( blessed $input && $input->isa( 'Zonemaster::Engine::Zone' ) ) {
|
||||
$attrs->{labels} = \@{ $input->name->labels };
|
||||
}
|
||||
elsif ( ref $input eq '' ) {
|
||||
$attrs->{labels} = [ split( /[.]/x, $input ) ];
|
||||
}
|
||||
elsif ( ref $input eq 'HASH' ) {
|
||||
confess "Attribute \(labels\) is required"
|
||||
if !exists $input->{labels};
|
||||
|
||||
confess "Argument must be an ARRAYREF: labels"
|
||||
if exists $input->{labels}
|
||||
&& ref $input->{labels} ne 'ARRAY';
|
||||
|
||||
$attrs->{labels} = $input->{labels};
|
||||
}
|
||||
else {
|
||||
my $what =
|
||||
( blessed $input )
|
||||
? "blessed(" . blessed $input . ")"
|
||||
: "ref(" . ref $input . ")";
|
||||
confess "Unrecognized argument: " . $what;
|
||||
}
|
||||
|
||||
return Class::Accessor::new( $class, $attrs );
|
||||
}
|
||||
|
||||
sub string {
|
||||
my $self = shift;
|
||||
|
||||
if ( not exists $self->{_string} ) {
|
||||
my $string = join( '.', @{ $self->labels } );
|
||||
$string = '.' if $string eq q{};
|
||||
|
||||
$self->{_string} = $string;
|
||||
}
|
||||
|
||||
return $self->{_string};
|
||||
}
|
||||
|
||||
sub fqdn {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return join( '.', @{ $self->labels } ) . '.';
|
||||
}
|
||||
|
||||
sub str_cmp {
|
||||
# For performance reasons, we do not unpack @_.
|
||||
# As a reminder, the calling convention is my ( $self, $other, $swap ) = @_.
|
||||
|
||||
my $me = uc ( $_[0]->{_string} // $_[0]->string );
|
||||
|
||||
# Treat undefined value as root
|
||||
my $other = $_[1] // q{};
|
||||
|
||||
if ( blessed $other and $other->isa( 'Zonemaster::Engine::DNSName' ) ) {
|
||||
return $me cmp uc( $other->{_string} // $other->string() );
|
||||
}
|
||||
else {
|
||||
# Assume $other is a string; remove trailing dot except if only character
|
||||
return $me cmp uc( $other =~ s/.\K [.] \z//xr );
|
||||
}
|
||||
}
|
||||
|
||||
sub next_higher {
|
||||
my $self = shift;
|
||||
my @l = @{ $self->labels };
|
||||
if ( @l ) {
|
||||
shift @l;
|
||||
return Zonemaster::Engine::DNSName->new({ labels => \@l });
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub common {
|
||||
my ( $self, $other ) = @_;
|
||||
|
||||
my @me = reverse @{ $self->labels };
|
||||
my @them = reverse @{ $other->labels };
|
||||
|
||||
my $count = 0;
|
||||
while ( @me and @them ) {
|
||||
my $m = shift @me;
|
||||
my $t = shift @them;
|
||||
if ( uc( $m ) eq uc( $t ) ) {
|
||||
$count += 1;
|
||||
next;
|
||||
}
|
||||
else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
return $count;
|
||||
} ## end sub common
|
||||
|
||||
sub is_in_bailiwick {
|
||||
my ( $self, $other ) = @_;
|
||||
|
||||
return scalar( @{ $self->labels } ) == $self->common( $other );
|
||||
}
|
||||
|
||||
sub prepend {
|
||||
my ( $self, $label ) = @_;
|
||||
my @labels = ( $label, @{ $self->labels } );
|
||||
|
||||
return $self->new( { labels => \@labels } );
|
||||
}
|
||||
|
||||
sub TO_JSON {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $self->string;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::DNSName - class representing DNS names
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $name1 = Zonemaster::Name->new('www.example.org');
|
||||
my $name2 = Zonemaster::Name->new('ns.example.org');
|
||||
say "Yay!" if $name1->common($name2) == 2;
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item labels
|
||||
|
||||
A reference to a list of strings, being the labels the DNS name is made up from.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item new($input) _or_ new({ labels => \@labellist })
|
||||
|
||||
The constructor can be called with either a single argument or with a reference
|
||||
to a hash as in the example above.
|
||||
|
||||
If there is a single argument, it must be either a non-reference, a
|
||||
L<Zonemaster::Engine::DNSName> object or a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
If it's a non-reference, it will be split at period characters (possibly after
|
||||
stringification) and the resulting list used as the name's labels.
|
||||
|
||||
If it's a L<Zonemaster::Engine::DNSName> object it will simply be returned.
|
||||
|
||||
If it's a L<Zonemaster::Engine::Zone> object, the value of its C<name> attribute will
|
||||
be returned.
|
||||
|
||||
=item from_string($domain)
|
||||
|
||||
A specialized constructor that must be called with a string.
|
||||
|
||||
=item string()
|
||||
|
||||
Returns a string representation of the name. The string representation is created by joining the labels with dots. If there are no labels, a
|
||||
single dot is returned. The names created this way do not have a trailing dot.
|
||||
|
||||
The stringification operator is overloaded to this function, so it should rarely be necessary to call it directly.
|
||||
|
||||
=item fqdn()
|
||||
|
||||
Returns the name as a string complete with a trailing dot.
|
||||
|
||||
=item str_cmp($other)
|
||||
|
||||
Overloads string comparison. Comparison is made after converting the names to upper case, and ignores any trailing dot on the other name.
|
||||
|
||||
=item next_higher()
|
||||
|
||||
Returns a new L<Zonemaster::Engine::DNSName> object, representing the name of the called one with the leftmost label removed.
|
||||
|
||||
=item common($other)
|
||||
|
||||
Returns the number of labels from the rightmost going left that are the same in both names. Used by the recursor to check for redirections going
|
||||
up the DNS tree.
|
||||
|
||||
=item is_in_bailiwick($other)
|
||||
|
||||
Returns true if $other is in-bailiwick of $self, and false otherwise.
|
||||
See also L<https://tools.ietf.org/html/rfc7719#section-6>.
|
||||
|
||||
=item prepend($label)
|
||||
|
||||
Returns a new L<Zonemaster::Engine::DNSName> object, representing the called one with the given label prepended.
|
||||
|
||||
=item TO_JSON
|
||||
|
||||
Helper method for JSON encoding.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
51
zonemaster-engine/lib/Zonemaster/Engine/Exception.pm
Normal file
51
zonemaster-engine/lib/Zonemaster/Engine/Exception.pm
Normal file
@@ -0,0 +1,51 @@
|
||||
package Zonemaster::Engine::Exception;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.3");
|
||||
|
||||
use Class::Accessor "antlers";
|
||||
|
||||
use overload '""' => \&string;
|
||||
|
||||
has 'message' => ( is => 'ro', isa => 'Str', required => 1 );
|
||||
|
||||
sub string {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $self->message;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Exception -- base class for Zonemaster::Engine exceptions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
die Zonemaster::Engine::Exception->new({ message => "This is an exception" });
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item message
|
||||
|
||||
A string attribute holding a message for possible human consumption.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item string()
|
||||
|
||||
Method that stringifies the object by returning the C<message> attribute.
|
||||
Stringification is overloaded to this.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
277
zonemaster-engine/lib/Zonemaster/Engine/Logger.pm
Normal file
277
zonemaster-engine/lib/Zonemaster/Engine/Logger.pm
Normal file
@@ -0,0 +1,277 @@
|
||||
package Zonemaster::Engine::Logger;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.8");
|
||||
|
||||
use Class::Accessor "antlers";
|
||||
|
||||
use Carp qw( confess );
|
||||
use Data::Dumper;
|
||||
use JSON::PP;
|
||||
use List::MoreUtils qw[none any];
|
||||
use Scalar::Util qw[blessed];
|
||||
use Zonemaster::Engine::Profile;
|
||||
use Zonemaster::Engine::Logger::Entry;
|
||||
|
||||
our $TEST_CASE_NAME = 'Unspecified';
|
||||
our $MODULE_NAME = 'System';
|
||||
|
||||
has 'entries' => (
|
||||
is => 'ro',
|
||||
isa => 'ArrayRef[Zonemaster::Engine::Logger::Entry]',
|
||||
);
|
||||
has 'callback' => (
|
||||
is => 'rw',
|
||||
isa => 'CodeRef',
|
||||
);
|
||||
|
||||
my $logfilter;
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
confess "must be called without arguments"
|
||||
if scalar( @_ ) != 0;
|
||||
|
||||
my $class = ref $proto || $proto;
|
||||
return Class::Accessor::new( $class, { entries => [] } );
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ( $self, $tag, $argref, $module, $testcase ) = @_;
|
||||
|
||||
$module //= $MODULE_NAME;
|
||||
$testcase //= $TEST_CASE_NAME;
|
||||
|
||||
my $new =
|
||||
Zonemaster::Engine::Logger::Entry->new( { tag => uc( $tag ), args => $argref, testcase => $testcase, module => $module } );
|
||||
$self->_check_filter( $new );
|
||||
push @{ $self->entries }, $new;
|
||||
|
||||
if ( $self->callback and ref( $self->callback ) eq 'CODE' ) {
|
||||
eval { $self->callback->( $new ) };
|
||||
if ( $@ ) {
|
||||
my $err = $@;
|
||||
if ( blessed( $err ) and $err->isa( "Zonemaster::Engine::Exception" ) ) {
|
||||
die $err;
|
||||
}
|
||||
else {
|
||||
$self->callback( undef );
|
||||
$self->add( LOGGER_CALLBACK_ERROR => { exception => $err } );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $new;
|
||||
} ## end sub add
|
||||
|
||||
sub _check_filter {
|
||||
my ( $self, $entry ) = @_;
|
||||
|
||||
if ( ! defined $logfilter ) {
|
||||
$logfilter = Zonemaster::Engine::Profile->effective->get(q{logfilter});
|
||||
}
|
||||
|
||||
if ( $logfilter ) {
|
||||
if ( $logfilter->{ uc $entry->module } ) {
|
||||
my $match = 0;
|
||||
foreach my $rule ( @{$logfilter->{ uc $entry->module }{ $entry->tag }} ) {
|
||||
foreach my $key ( keys %{ $rule->{when} } ) {
|
||||
my $cond = $rule->{when}{$key};
|
||||
if ( ref( $cond ) and ref( $cond ) eq 'ARRAY' ) {
|
||||
if ( any { $_ eq $entry->args->{$key} } @$cond ) {
|
||||
$match = 1;
|
||||
} else {
|
||||
$match = 0;
|
||||
last;
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ( $cond eq $entry->args->{$key} ) {
|
||||
$match = 1;
|
||||
} else {
|
||||
$match = 0;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
if ( $match ) {
|
||||
$entry->_set_level( $rule->{set} );
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return;
|
||||
} ## end sub _check_filter
|
||||
|
||||
sub start_time_now {
|
||||
Zonemaster::Engine::Logger::Entry->start_time_now();
|
||||
return;
|
||||
}
|
||||
|
||||
sub reset_config {
|
||||
$logfilter = undef;
|
||||
Zonemaster::Engine::Logger::Entry->reset_config();
|
||||
return;
|
||||
}
|
||||
|
||||
sub clear_history {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $r = $self->entries;
|
||||
splice @$r, 0, scalar( @$r );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# get the max level from a log, return as a string
|
||||
sub get_max_level {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my %levels = reverse Zonemaster::Engine::Logger::Entry->levels();
|
||||
my $level = 0;
|
||||
|
||||
foreach ( @{ $self->entries } ) {
|
||||
$level = $_->numeric_level if $_->numeric_level > $level;
|
||||
}
|
||||
|
||||
return $levels{$level};
|
||||
}
|
||||
|
||||
sub json {
|
||||
my ( $self, $min_level ) = @_;
|
||||
my $json = JSON::PP->new->allow_blessed->convert_blessed->canonical;
|
||||
my %numeric = Zonemaster::Engine::Logger::Entry->levels();
|
||||
|
||||
my @msg = @{ $self->entries };
|
||||
|
||||
if ( $min_level and defined $numeric{ uc( $min_level ) } ) {
|
||||
@msg = grep { $_->numeric_level >= $numeric{ uc( $min_level ) } } @msg;
|
||||
}
|
||||
|
||||
my @out;
|
||||
foreach my $m ( @msg ) {
|
||||
my %r;
|
||||
$r{timestamp} = $m->timestamp;
|
||||
$r{module} = $m->module;
|
||||
$r{testcase} = $m->testcase;
|
||||
$r{tag} = $m->tag;
|
||||
$r{level} = $m->level;
|
||||
$r{args} = $m->args if $m->args;
|
||||
|
||||
push @out, \%r;
|
||||
}
|
||||
|
||||
return $json->encode( \@out );
|
||||
} ## end sub json
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Logger - class that holds L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $logger = Zonemaster::Engine::Logger->new;
|
||||
$logger->add( TAG => {some => 'arguments'});
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new object.
|
||||
|
||||
my $logger = Zonemaster::Engine::Logger->new;
|
||||
|
||||
=back
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item entries
|
||||
|
||||
A reference to an array holding L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=item callback($coderef)
|
||||
|
||||
If this attribute is set, the given code reference will be called every time a
|
||||
log entry is added. The referenced code will be called with the newly created
|
||||
entry as its single argument. The return value of the called code is ignored.
|
||||
|
||||
If the called code throws an exception, and the exception is not an object of
|
||||
class L<Zonemaster::Engine::Exception> (or a subclass of it), the exception will be
|
||||
logged as a system message at default level C<CRITICAL> and the callback
|
||||
attribute will be cleared.
|
||||
|
||||
If an exception that is of (sub)class L<Zonemaster::Engine::Exception> is called, the
|
||||
exception will simply be rethrown until it reaches the code that started the
|
||||
test run that logged the message.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item add($tag, $argref, $module, $testcase)
|
||||
|
||||
Adds an entry with the given tag and arguments to the logger object.
|
||||
|
||||
C<$module> is optional and will default to
|
||||
C<$Zonemaster::Engine::Logger::MODULE_NAME> if not set.
|
||||
|
||||
C<$testcase> is optional and will default to
|
||||
C<$Zonemaster::Engine::Logger::TEST_CASE_NAME> if not set.
|
||||
|
||||
The variables C<$Zonemaster::Engine::Logger::MODULE_NAME> and
|
||||
C<$Zonemaster::Engine::Logger::TEST_CASE_NAME> can be dynamically set to
|
||||
change the default module ("System") or test case name ("Unspecified").
|
||||
|
||||
=item json([$level])
|
||||
|
||||
Returns a JSON-formatted string with all the stored log entries. If an argument
|
||||
is given and is a known severity level, only messages with at least that level
|
||||
will be included.
|
||||
|
||||
=item get_max_level
|
||||
|
||||
Returns the maximum log level from the entire log as the level string.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item start_time_now()
|
||||
|
||||
Set the logger's start time to the current time.
|
||||
|
||||
=item clear_history()
|
||||
|
||||
Remove all known log entries.
|
||||
|
||||
=item reset_config()
|
||||
|
||||
Clear the test level cached configuration.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=over
|
||||
|
||||
=item _check_filter($entry)
|
||||
|
||||
Apply the C<logfilter> defined rules to the entry. See
|
||||
L<Zonemaster::Engine::Profile/"logfilter">.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
263
zonemaster-engine/lib/Zonemaster/Engine/Logger/Entry.pm
Normal file
263
zonemaster-engine/lib/Zonemaster/Engine/Logger/Entry.pm
Normal file
@@ -0,0 +1,263 @@
|
||||
package Zonemaster::Engine::Logger::Entry;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.1.8");
|
||||
|
||||
use Carp qw( confess );
|
||||
use Time::HiRes qw[time];
|
||||
use JSON::PP;
|
||||
use Class::Accessor;
|
||||
|
||||
use Zonemaster::Engine::Profile;
|
||||
|
||||
use base qw(Class::Accessor);
|
||||
|
||||
use overload '""' => \&string;
|
||||
|
||||
our %numeric = (
|
||||
DEBUG3 => -2,
|
||||
DEBUG2 => -1,
|
||||
DEBUG => 0,
|
||||
INFO => 1,
|
||||
NOTICE => 2,
|
||||
WARNING => 3,
|
||||
ERROR => 4,
|
||||
CRITICAL => 5,
|
||||
);
|
||||
|
||||
our $start_time = time();
|
||||
|
||||
my $json = JSON::PP->new->allow_blessed->convert_blessed->canonical;
|
||||
my $test_levels_config;
|
||||
|
||||
__PACKAGE__->mk_ro_accessors(qw(tag args timestamp testcase module));
|
||||
|
||||
|
||||
sub new {
|
||||
my ( $proto, $attrs ) = @_;
|
||||
# tag, testcase and module required, args optional, other built
|
||||
|
||||
confess "Attribute \(tag\) is required"
|
||||
if !exists $attrs->{tag};
|
||||
|
||||
confess "Attribute \(testcase\) is required"
|
||||
if !exists $attrs->{testcase};
|
||||
|
||||
confess "Attribute \(module\) is required"
|
||||
if !exists $attrs->{module};
|
||||
|
||||
confess "Argument must be a HASHREF: args"
|
||||
if exists $attrs->{args}
|
||||
&& ref $attrs->{args} ne 'HASH';
|
||||
|
||||
my $time = time() - $start_time;
|
||||
$time =~ s/,/\./;
|
||||
$attrs->{timestamp} = $time;
|
||||
|
||||
# lazy attributes
|
||||
$attrs->{_level} = delete $attrs->{level} if exists $attrs->{level};
|
||||
|
||||
my $class = ref $proto || $proto;
|
||||
return Class::Accessor::new( $class, $attrs );
|
||||
}
|
||||
|
||||
sub level {
|
||||
my $self = shift;
|
||||
|
||||
# Lazy default value
|
||||
if ( !exists $self->{_level} ) {
|
||||
$self->{_level} = $self->_build_level();
|
||||
}
|
||||
|
||||
return $self->{_level}
|
||||
}
|
||||
|
||||
sub _build_level {
|
||||
my ( $self ) = @_;
|
||||
my $string;
|
||||
|
||||
if ( !defined $test_levels_config ) {
|
||||
$test_levels_config = Zonemaster::Engine::Profile->effective->get( q{test_levels} );
|
||||
}
|
||||
|
||||
if ( exists $test_levels_config->{ uc $self->module }{ $self->tag } ) {
|
||||
$string = uc $test_levels_config->{ uc $self->module }{ $self->tag };
|
||||
}
|
||||
else {
|
||||
$string = 'DEBUG';
|
||||
}
|
||||
|
||||
if ( defined $numeric{$string} ) {
|
||||
return $string;
|
||||
}
|
||||
else {
|
||||
die "Unknown level string: $string";
|
||||
}
|
||||
}
|
||||
|
||||
sub _set_level {
|
||||
my ( $self, $level ) = @_;
|
||||
|
||||
$self->{_level} = $level
|
||||
}
|
||||
|
||||
|
||||
sub numeric_level {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $numeric{ $self->level };
|
||||
}
|
||||
|
||||
sub levels {
|
||||
return %numeric;
|
||||
}
|
||||
|
||||
sub string {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return sprintf( '%s%s:%s %s', $self->module, $self->testcase ? q{:} . $self->testcase : q{}, $self->tag, $self->argstr );
|
||||
}
|
||||
|
||||
sub argstr {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $argstr = q{};
|
||||
## no critic (TestingAndDebugging::ProhibitNoWarnings)
|
||||
no warnings 'uninitialized';
|
||||
|
||||
if ( $self->args ) {
|
||||
my $p_args = $self->printable_args;
|
||||
$argstr = join( q{; },
|
||||
map { $_ . q{=} . ( ref( $p_args->{$_} ) ? $json->encode( $p_args->{$_} ) : $p_args->{$_} ) }
|
||||
sort keys %{$p_args} );
|
||||
}
|
||||
|
||||
return $argstr;
|
||||
}
|
||||
|
||||
sub printable_args {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->args ) {
|
||||
my %p_args;
|
||||
foreach my $key_arg ( keys %{ $self->args } ) {
|
||||
if ( not ref( $self->args->{$key_arg} ) ) {
|
||||
$p_args{$key_arg} = $self->args->{$key_arg};
|
||||
}
|
||||
elsif ( $key_arg eq q{asn} and ref( $self->args->{$key_arg} ) eq q{ARRAY} ) {
|
||||
$p_args{q{asn}} = join( q{,}, @{ $self->args->{$key_arg} } );
|
||||
}
|
||||
else {
|
||||
$p_args{$key_arg} = $self->args->{$key_arg};
|
||||
}
|
||||
}
|
||||
return \%p_args;
|
||||
}
|
||||
|
||||
return;
|
||||
} ## end sub printable_args
|
||||
|
||||
###
|
||||
### Class method
|
||||
###
|
||||
|
||||
sub start_time_now {
|
||||
$start_time = time();
|
||||
return;
|
||||
}
|
||||
|
||||
sub reset_config {
|
||||
undef $test_levels_config;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Logger::Entry - module for single log entries
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Zonemaster::Engine->logger->add( TAG => { some => 'arguments' });
|
||||
|
||||
There should never be a need to create a log entry object in isolation. They should always be associated with and created via a logger object.
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new object.
|
||||
|
||||
=item levels
|
||||
|
||||
Returns a hash where the keys are log levels as strings and the corresponding values their numeric value.
|
||||
|
||||
=item start_time_now()
|
||||
|
||||
Set the logger's start time to the current time.
|
||||
|
||||
=item reset_config()
|
||||
|
||||
Clear the test level cached configuration.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item module
|
||||
|
||||
The name of the module associated to the entry, or "System".
|
||||
|
||||
=item testcase
|
||||
|
||||
The name of the test case which generated the entry, or "Unspecified".
|
||||
|
||||
=item tag
|
||||
|
||||
The tag that was set when the entry was created.
|
||||
|
||||
=item args
|
||||
|
||||
The argument hash reference that was provided when the entry was created.
|
||||
|
||||
=item timestamp
|
||||
|
||||
The time after the current program started running when this entry was created. This is a floating-point value with the precision provided by
|
||||
L<Time::HiRes>.
|
||||
|
||||
=item level
|
||||
|
||||
The log level associated to this log entry.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item string
|
||||
|
||||
Simple method to generate a string representation of the log entry. Overloaded to the stringification operator.
|
||||
|
||||
=item argstr
|
||||
|
||||
Returns the string representation of the message arguments.
|
||||
|
||||
=item printable_args
|
||||
|
||||
Used to transform data from an internal/JSON representation to a "user friendly" representation one.
|
||||
|
||||
=item numeric_level
|
||||
|
||||
Returns the log level of the entry in numeric form.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
196
zonemaster-engine/lib/Zonemaster/Engine/NSArray.pm
Normal file
196
zonemaster-engine/lib/Zonemaster/Engine/NSArray.pm
Normal file
@@ -0,0 +1,196 @@
|
||||
package Zonemaster::Engine::NSArray;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.3");
|
||||
|
||||
use Carp qw( confess croak );
|
||||
use Zonemaster::Engine::Recursor;
|
||||
use Zonemaster::Engine::Nameserver;
|
||||
|
||||
use Class::Accessor 'antlers';
|
||||
|
||||
has 'names' => ( is => 'ro', isa => 'ArrayRef', required => 1 );
|
||||
has 'ary' => ( is => 'ro', isa => 'ArrayRef', default => sub { [] } );
|
||||
|
||||
sub TIEARRAY {
|
||||
my ( $class, @names ) = @_;
|
||||
|
||||
return $class->new(
|
||||
{
|
||||
ary => [],
|
||||
names => [ sort { $a cmp $b } @names ]
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my ( $self, $index, $value ) = @_;
|
||||
|
||||
croak "STORE forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub STORESIZE {
|
||||
my ( $self, $index, $value ) = @_;
|
||||
|
||||
croak "STORESIZE forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ( $self, $index ) = @_;
|
||||
|
||||
if ( exists $self->ary->[$index] ) {
|
||||
return $self->ary->[$index];
|
||||
}
|
||||
elsif ( scalar( @{ $self->names } ) == 0 ) {
|
||||
return;
|
||||
}
|
||||
else {
|
||||
$self->_load_name( shift @{ $self->names } );
|
||||
return $self->FETCH( $index );
|
||||
}
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my ( $self ) = @_;
|
||||
|
||||
while ( my $name = shift @{ $self->names } ) {
|
||||
$self->_load_name( $name );
|
||||
}
|
||||
|
||||
return scalar( @{ $self->ary } );
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ( $self, $index ) = @_;
|
||||
|
||||
if ( $self->FETCH( $index ) ) {
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ( $self, $index ) = @_;
|
||||
|
||||
croak "DELETE forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my ( $self ) = @_;
|
||||
|
||||
croak "CLEAR forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub PUSH {
|
||||
my ( $self, @values ) = @_;
|
||||
|
||||
croak "PUSH forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub UNSHIFT {
|
||||
my ( $self, @values ) = @_;
|
||||
|
||||
croak "UNSHIFT forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub POP {
|
||||
my ( $self ) = @_;
|
||||
|
||||
croak "POP forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub SHIFT {
|
||||
my ( $self ) = @_;
|
||||
|
||||
croak "SHIFT forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub SPLICE {
|
||||
my ( $self, $offset, $length, @values ) = @_;
|
||||
|
||||
croak "SPLICE forbidden for this type of array.";
|
||||
}
|
||||
|
||||
sub UNTIE {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _load_name {
|
||||
my ( $self, $name ) = @_;
|
||||
my @addrs = Zonemaster::Engine::Recursor->get_addresses_for( $name );
|
||||
foreach my $addr ( sort { $a->ip cmp $b->ip } @addrs ) {
|
||||
my $ns = Zonemaster::Engine::Nameserver->new( { name => $name, address => $addr } );
|
||||
if ( not grep { "$ns" eq "$_" } @{ $self->ary } ) {
|
||||
push @{ $self->ary }, $ns;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::NSArray - Class implementing arrays that lazily looks up name server addresses from their names
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
tie @ary, 'Zonemaster::Engine::NSArray', @ns_names
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is used for the C<glue> and C<ns> attributes of the
|
||||
L<Zonemaster::Engine::Zone> class. It is initially seeded with a list of
|
||||
names, which will be expanded into proper L<Zonemaster::Engine::Nameserver>
|
||||
objects on demand. Be careful with using Perl functions that act on
|
||||
whole arrays (particularly C<foreach>), since they will usually force
|
||||
the entire array to expand, negating the use of the lazy-loading.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These are all methods implementing the Perl tie interface. They have no independent use.
|
||||
|
||||
=over
|
||||
|
||||
=item TIEARRAY
|
||||
|
||||
=item STORE
|
||||
|
||||
=item STORESIZE
|
||||
|
||||
=item FETCH
|
||||
|
||||
=item FETCHSIZE
|
||||
|
||||
=item EXISTS
|
||||
|
||||
=item DELETE
|
||||
|
||||
=item CLEAR
|
||||
|
||||
=item PUSH
|
||||
|
||||
=item UNSHIFT
|
||||
|
||||
=item POP
|
||||
|
||||
=item SHIFT
|
||||
|
||||
=item SPLICE
|
||||
|
||||
=item UNTIE
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Calle Dybedahl, C<< <calle at init.se> >>
|
||||
|
||||
=cut
|
||||
919
zonemaster-engine/lib/Zonemaster/Engine/Nameserver.pm
Normal file
919
zonemaster-engine/lib/Zonemaster/Engine/Nameserver.pm
Normal file
@@ -0,0 +1,919 @@
|
||||
package Zonemaster::Engine::Nameserver;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.1.16");
|
||||
|
||||
use Class::Accessor qw[ antlers ];
|
||||
|
||||
use Zonemaster::Engine::DNSName;
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::Engine::Packet;
|
||||
use Zonemaster::Engine::Nameserver::Cache;
|
||||
use Zonemaster::Engine::Recursor;
|
||||
use Zonemaster::Engine::Constants qw( :ip :misc );
|
||||
use Zonemaster::LDNS;
|
||||
|
||||
use Net::IP::XS;
|
||||
use Time::HiRes qw[time];
|
||||
use JSON::PP;
|
||||
use MIME::Base64;
|
||||
use Module::Find qw[useall];
|
||||
use Carp qw( confess croak );
|
||||
use List::Util qw[max min sum];
|
||||
use Digest::MD5;
|
||||
use POSIX ();
|
||||
use Scalar::Util qw[ blessed ];
|
||||
|
||||
our @ISA = qw (Class::Accessor);
|
||||
|
||||
use overload
|
||||
'""' => \&string,
|
||||
'cmp' => \&compare;
|
||||
|
||||
has 'name' => ( is => 'ro' );
|
||||
has 'address' => ( is => 'ro' );
|
||||
|
||||
has 'dns' => ( is => 'ro' );
|
||||
has 'cache' => ( is => 'ro' );
|
||||
has 'times' => ( is => 'ro' );
|
||||
|
||||
has 'fake_delegations' => ( is => 'ro' );
|
||||
has 'fake_ds' => ( is => 'ro' );
|
||||
|
||||
has 'blacklisted' => ( is => 'rw' );
|
||||
|
||||
###
|
||||
### Variables
|
||||
###
|
||||
|
||||
our %object_cache;
|
||||
our %address_object_cache;
|
||||
our %address_repr_cache;
|
||||
|
||||
###
|
||||
### Build methods for attributes
|
||||
###
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $attrs = shift;
|
||||
|
||||
my %lazy_attrs;
|
||||
$lazy_attrs{dns} = delete $attrs->{dns} if exists $attrs->{dns};
|
||||
$lazy_attrs{cache} = delete $attrs->{cache} if exists $attrs->{cache};
|
||||
|
||||
# Required arguments
|
||||
confess "Attribute \(address\) is required"
|
||||
if !defined $attrs->{address};
|
||||
|
||||
# Type coercions
|
||||
$attrs->{name} = Zonemaster::Engine::DNSName->from_string( $attrs->{name} )
|
||||
if !blessed $attrs->{name} || !$attrs->{name}->isa( 'Zonemaster::Engine::DNSName' );
|
||||
|
||||
my $name = lc( q{} . $attrs->{name} );
|
||||
$name = '$$$NONAME' if $name eq q{};
|
||||
|
||||
my $address;
|
||||
|
||||
# Use a object cache for IP type coercion (don't parse IP unless it is needed)
|
||||
if (!blessed $attrs->{address} || !$attrs->{address}->isa( 'Net::IP::XS' )) {
|
||||
if (!exists $address_object_cache{$attrs->{address}}) {
|
||||
$address_object_cache{$attrs->{address}} = Net::IP::XS->new($attrs->{address});
|
||||
$address_repr_cache{$attrs->{address}} = $address_object_cache{$attrs->{address}}->short;
|
||||
}
|
||||
# Fetch IP object from the address cache (avoid object creation and method call)
|
||||
$address = $address_repr_cache{$attrs->{address}};
|
||||
$attrs->{address} = $address_object_cache{$attrs->{address}};
|
||||
} else {
|
||||
$address = $attrs->{address}->short;
|
||||
}
|
||||
|
||||
# Return Nameserver object as soon as possible
|
||||
if ( exists $object_cache{$name}{$address} ) {
|
||||
return $object_cache{$name}{$address};
|
||||
}
|
||||
|
||||
# Type constraints
|
||||
confess "Argument must be coercible into a Zonemaster::Engine::DNSName: name"
|
||||
if !$attrs->{name}->isa( 'Zonemaster::Engine::DNSName' );
|
||||
confess "Argument must be coercible into a Net::IP::XS: address"
|
||||
if exists $attrs->{address}
|
||||
&& !$attrs->{address}->isa( 'Net::IP::XS' );
|
||||
confess "Argument must be an ARRAYREF: times"
|
||||
if exists $attrs->{times}
|
||||
&& ref $attrs->{times} ne 'ARRAY';
|
||||
confess "Argument must be a HASHREF: fake_delegations"
|
||||
if exists $attrs->{fake_delegations}
|
||||
&& ref $attrs->{fake_delegations} ne 'HASH';
|
||||
confess "Argument must be a HASHREF: fake_ds"
|
||||
if exists $attrs->{fake_ds}
|
||||
&& ref $attrs->{fake_ds} ne 'HASH';
|
||||
confess "Argument must be a HASHREF: blacklisted"
|
||||
if exists $attrs->{blacklisted}
|
||||
&& ref $attrs->{blacklisted} ne 'HASH';
|
||||
confess "Argument must be a Zonemaster::LDNS: dns"
|
||||
if exists $lazy_attrs{dns}
|
||||
&& ( !blessed $lazy_attrs{dns} || !$lazy_attrs{dns}->isa( 'Zonemaster::LDNS' ) );
|
||||
confess "Argument must be a Zonemaster::Engine::Nameserver::Cache: cache"
|
||||
if exists $lazy_attrs{cache}
|
||||
&& ( !blessed $lazy_attrs{cache} || !$lazy_attrs{cache}->isa( 'Zonemaster::Engine::Nameserver::Cache' ) );
|
||||
|
||||
# Default values
|
||||
$attrs->{blacklisted} //= {};
|
||||
$attrs->{fake_delegations} //= {};
|
||||
$attrs->{fake_ds} //= {};
|
||||
$attrs->{times} //= [];
|
||||
|
||||
my $obj = Class::Accessor::new( $class, $attrs );
|
||||
$obj->{_dns} = $lazy_attrs{dns} if exists $lazy_attrs{dns};
|
||||
$obj->{_cache} = $lazy_attrs{cache} if exists $lazy_attrs{cache};
|
||||
|
||||
$obj->{_string} = $name . q{/} . $address;
|
||||
|
||||
Zonemaster::Engine->logger->add( NS_CREATED => { name => $name, ip => $address } );
|
||||
$object_cache{$name}{$address} = $obj;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub dns {
|
||||
my $self = shift;
|
||||
|
||||
# Lazy default value
|
||||
if ( !exists $self->{_dns} ) {
|
||||
$self->{_dns} = $self->_build_dns();
|
||||
}
|
||||
|
||||
return $self->{_dns};
|
||||
}
|
||||
|
||||
sub cache {
|
||||
my $self = shift;
|
||||
|
||||
# Lazy default value
|
||||
if ( !exists $self->{_cache} ) {
|
||||
$self->{_cache} = $self->_build_cache();
|
||||
}
|
||||
|
||||
return $self->{_cache};
|
||||
}
|
||||
|
||||
sub _build_dns {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $res = Zonemaster::LDNS->new( $self->address->ip );
|
||||
|
||||
$res->recurse( 0 );
|
||||
$res->dnssec( 0 );
|
||||
$res->edns_size( 0 );
|
||||
|
||||
$res->retry( Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.retry} ) );
|
||||
$res->retrans( Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.retrans} ) );
|
||||
$res->debug( Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.debug} ) );
|
||||
$res->timeout( Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.timeout} ) );
|
||||
|
||||
my $src_address = $self->source_address();
|
||||
if ( defined( $src_address ) ) {
|
||||
$res->source( $src_address );
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub _build_cache {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $cache_type = Zonemaster::Engine::Nameserver::Cache->get_cache_type( Zonemaster::Engine::Profile->effective );
|
||||
my $cache_class = Zonemaster::Engine::Nameserver::Cache->get_cache_class( $cache_type );
|
||||
|
||||
$cache_class->new( { address => $self->address } );
|
||||
}
|
||||
|
||||
###
|
||||
### Public Methods (and helpers)
|
||||
###
|
||||
|
||||
sub query {
|
||||
my ( $self, $name, $type, $href ) = @_;
|
||||
$type //= 'A';
|
||||
|
||||
my $address = $self->address;
|
||||
my $profile = Zonemaster::Engine::Profile->effective;
|
||||
|
||||
if ( $address->version == 4 and not $profile->get( q{net.ipv4} ) ) {
|
||||
Zonemaster::Engine->logger->add( IPV4_BLOCKED => { ns => $self->string } );
|
||||
return;
|
||||
}
|
||||
|
||||
if ( $address->version == 6 and not $profile->get( q{net.ipv6} ) ) {
|
||||
Zonemaster::Engine->logger->add( IPV6_BLOCKED => { ns => $self->string } );
|
||||
return;
|
||||
}
|
||||
|
||||
Zonemaster::Engine->logger->add(
|
||||
'QUERY',
|
||||
{
|
||||
name => "$name",
|
||||
type => $type,
|
||||
flags => $href,
|
||||
ip => $address->short
|
||||
}
|
||||
);
|
||||
|
||||
my $class = $href->{class} // 'IN';
|
||||
my $dnssec = $href->{dnssec} // 0;
|
||||
my $usevc = $href->{usevc} // 0;
|
||||
my $recurse = $href->{recurse} // 0;
|
||||
|
||||
if ( exists $href->{edns_details} and exists $href->{edns_details}{do} ) {
|
||||
$dnssec = $href->{edns_details}{do};
|
||||
}
|
||||
|
||||
my $edns_size = $href->{edns_size} // ( $dnssec ? $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT : 0 );
|
||||
|
||||
# Fake a DS answer
|
||||
if ( $type eq 'DS' and $class eq 'IN' and $self->fake_ds->{ lc( $name ) } ) {
|
||||
my $p = Zonemaster::LDNS::Packet->new( $name, $type, $class );
|
||||
|
||||
$p->qr( 1 );
|
||||
$p->aa( 1 );
|
||||
$p->do( $dnssec );
|
||||
$p->rd( $recurse );
|
||||
|
||||
foreach my $rr ( @{ $self->fake_ds->{ lc( $name ) } } ) {
|
||||
$p->unique_push( 'answer', $rr );
|
||||
}
|
||||
|
||||
my $res = Zonemaster::Engine::Packet->new( { packet => $p } );
|
||||
Zonemaster::Engine->logger->add( FAKE_DS_RETURNED => { name => "$name", type => $type, class => $class, from => "$self" } );
|
||||
Zonemaster::Engine->logger->add( FAKE_PACKET_RETURNED => { packet => $res->string } );
|
||||
return $res;
|
||||
}
|
||||
|
||||
# Fake a delegation
|
||||
foreach my $fname ( sort keys %{ $self->fake_delegations } ) {
|
||||
if ( $name =~ m/([.]|\A)\Q$fname\E\z/xi ) {
|
||||
my $p = Zonemaster::LDNS::Packet->new( $name, $type, $class );
|
||||
|
||||
if ( lc( $name ) eq lc( $fname ) and $type eq 'NS' ) {
|
||||
my $name = $self->fake_delegations->{$fname}{authority};
|
||||
my $addr = $self->fake_delegations->{$fname}{additional};
|
||||
$p->unique_push( 'answer', $_ ) for @{$name};
|
||||
$p->unique_push( 'additional', $_ ) for @{$addr};
|
||||
}
|
||||
elsif ( $type eq 'DS' ) {
|
||||
$p->aa( 1 );
|
||||
}
|
||||
else {
|
||||
while ( my ( $section, $aref ) = each %{ $self->fake_delegations->{$fname} } ) {
|
||||
$p->unique_push( $section, $_ ) for @{$aref};
|
||||
}
|
||||
}
|
||||
|
||||
$p->aa( 0 ) unless ( $type eq 'DS' );
|
||||
$p->qr( 1 );
|
||||
$p->do( $dnssec );
|
||||
$p->rd( $recurse );
|
||||
$p->answerfrom( $address->ip );
|
||||
|
||||
Zonemaster::Engine->logger->add( FAKE_DELEGATION_RETURNED => { name => "$name", type => $type, class => $class, from => "$self" } );
|
||||
|
||||
my $res = Zonemaster::Engine::Packet->new( { packet => $p } );
|
||||
Zonemaster::Engine->logger->add( FAKE_PACKET_RETURNED => { packet => $res->string } );
|
||||
return $res;
|
||||
} ## end if ( $name =~ m/([.]|\A)\Q$fname\E\z/xi)
|
||||
} ## end foreach my $fname ( sort keys...)
|
||||
|
||||
my $md5 = Digest::MD5->new;
|
||||
|
||||
$md5->add( q{NAME} , $name,
|
||||
q{TYPE} , "\U$type",
|
||||
q{CLASS} , "\U$class",
|
||||
q{DNSSEC} , $dnssec,
|
||||
q{USEVC} , $usevc,
|
||||
q{RECURSE} , $recurse );
|
||||
|
||||
if ( exists $href->{edns_details} ) {
|
||||
$md5->add( q{EDNS_VERSION} , $href->{edns_details}{version} // 0,
|
||||
q{EDNS_Z} , $href->{edns_details}{z} // 0,
|
||||
q{EDNS_EXTENDED_RCODE} , $href->{edns_details}{rcode} // 0,
|
||||
q{EDNS_DATA} , $href->{edns_details}{data} // q{} );
|
||||
$edns_size = $href->{edns_details}{size} // ( $href->{edns_size} // ( $dnssec ? $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT : $EDNS_UDP_PAYLOAD_DEFAULT ) );
|
||||
}
|
||||
|
||||
croak "edns_size (or edns_details->size) parameter must be a value between 0 and 65535" if $edns_size > 65535 or $edns_size < 0;
|
||||
|
||||
$md5->add( q{EDNS_UDP_SIZE} , $edns_size );
|
||||
|
||||
my $idx = $md5->b64digest();
|
||||
|
||||
my ( $in_cache, $p ) = $self->cache->get_key( $idx );
|
||||
if ( not $in_cache ) {
|
||||
$p = $self->_query( $name, $type, $href );
|
||||
$self->cache->set_key( $idx, $p );
|
||||
}
|
||||
|
||||
Zonemaster::Engine->logger->add( CACHED_RETURN => { packet => ( $p ? $p->string : 'undef' ) } );
|
||||
|
||||
return $p;
|
||||
} ## end sub query
|
||||
|
||||
sub add_fake_delegation {
|
||||
my ( $self, $domain, $href ) = @_;
|
||||
my %delegation;
|
||||
|
||||
$domain = q{} . Zonemaster::Engine::DNSName->new( $domain );
|
||||
foreach my $name ( keys %{$href} ) {
|
||||
push @{ $delegation{authority} }, Zonemaster::LDNS::RR->new( sprintf( '%s IN NS %s', $domain, $name ) );
|
||||
foreach my $ip ( @{ $href->{$name} } ) {
|
||||
if ( Net::IP::XS->new( $ip )->ip eq $self->address->ip ) {
|
||||
Zonemaster::Engine->logger->add( FAKE_DELEGATION_TO_SELF => { ns => "$self", domain => $domain, data => $href } );
|
||||
return;
|
||||
}
|
||||
|
||||
push @{ $delegation{additional} },
|
||||
Zonemaster::LDNS::RR->new( sprintf( '%s IN %s %s', $name, ( Net::IP::XS::ip_is_ipv6( $ip ) ? 'AAAA' : 'A' ), $ip ) );
|
||||
}
|
||||
}
|
||||
|
||||
$self->fake_delegations->{$domain} = \%delegation;
|
||||
Zonemaster::Engine->logger->add( FAKE_DELEGATION_ADDED => { ns => "$self", domain => $domain, data => $href } );
|
||||
|
||||
# We're changing the world, so the cache can't be trusted
|
||||
Zonemaster::Engine::Recursor->clear_cache;
|
||||
|
||||
return;
|
||||
} ## end sub add_fake_delegation
|
||||
|
||||
sub add_fake_ds {
|
||||
my ( $self, $domain, $aref ) = @_;
|
||||
my @ds;
|
||||
|
||||
if ( not ref $domain ) {
|
||||
$domain = Zonemaster::Engine::DNSName->new( $domain );
|
||||
}
|
||||
|
||||
foreach my $href ( @{$aref} ) {
|
||||
push @ds,
|
||||
Zonemaster::LDNS::RR->new(
|
||||
sprintf(
|
||||
'%s IN DS %d %d %d %s',
|
||||
"$domain", $href->{keytag}, $href->{algorithm}, $href->{type}, $href->{digest}
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
$self->fake_ds->{ lc( "$domain" ) } = \@ds;
|
||||
Zonemaster::Engine->logger->add( FAKE_DS_ADDED => { domain => lc( "$domain" ), data => $aref, ns => "$self" } );
|
||||
|
||||
# We're changing the world, so the cache can't be trusted
|
||||
Zonemaster::Engine::Recursor->clear_cache;
|
||||
|
||||
return;
|
||||
} ## end sub add_fake_ds
|
||||
|
||||
sub _query {
|
||||
my ( $self, $name, $type, $href ) = @_;
|
||||
my %flags;
|
||||
|
||||
$type //= 'A';
|
||||
$href->{class} //= 'IN';
|
||||
|
||||
if ( Zonemaster::Engine::Profile->effective->get( q{no_network} ) ) {
|
||||
croak sprintf
|
||||
"External query for %s, %s attempted to %s while running with no_network",
|
||||
$name, $type, $self->string;
|
||||
}
|
||||
|
||||
Zonemaster::Engine->logger->add(
|
||||
'external_query',
|
||||
{
|
||||
name => "$name",
|
||||
type => $type,
|
||||
flags => $href,
|
||||
ip => $self->address->short
|
||||
}
|
||||
);
|
||||
|
||||
# Make sure we have a value for each flag
|
||||
$flags{q{retry}} = $href->{q{retry}} // Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.retry} );
|
||||
$flags{q{retrans}} = $href->{q{retrans}}
|
||||
// Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.retrans} );
|
||||
$flags{q{dnssec}} = $href->{q{dnssec}} // 0;
|
||||
$flags{q{usevc}} = $href->{q{usevc}} // 0;
|
||||
$flags{q{igntc}} = $href->{q{igntc}} // 0;
|
||||
$flags{q{fallback}} = $href->{q{fallback}}
|
||||
// Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.fallback} );
|
||||
$flags{q{recurse}} = $href->{q{recurse}} // 0;
|
||||
$flags{q{timeout}} = $href->{q{timeout}}
|
||||
// Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.timeout} );
|
||||
|
||||
if ( exists $href->{edns_details} ) {
|
||||
$flags{q{dnssec}} = $href->{edns_details}{do} // $flags{q{dnssec}};
|
||||
$flags{q{edns_size}} = $href->{edns_details}{size} // ( $href->{q{edns_size}} // ( $flags{q{dnssec}} ? $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT : $EDNS_UDP_PAYLOAD_DEFAULT ) );
|
||||
}
|
||||
else {
|
||||
$flags{q{edns_size}} = $href->{q{edns_size}} // ( $flags{q{dnssec}} ? $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT : 0 );
|
||||
}
|
||||
|
||||
# Set flags for this query
|
||||
foreach my $flag ( keys %flags ) {
|
||||
$self->dns->$flag( $flags{$flag} );
|
||||
}
|
||||
|
||||
my $before = time();
|
||||
my $res;
|
||||
if ( $BLACKLISTING_ENABLED and $self->blacklisted->{ $flags{usevc} } ) {
|
||||
Zonemaster::Engine->logger->add(
|
||||
IS_BLACKLISTED => {
|
||||
message => "Server transport has been blacklisted due to previous failure",
|
||||
ns => "$self",
|
||||
name => "$name",
|
||||
type => $type,
|
||||
class => $href->{class},
|
||||
proto => $flags{usevc} ? q{TCP} : q{UDP},
|
||||
dnssec => $flags{dnssec},
|
||||
edns_size => $flags{q{edns_size}}
|
||||
}
|
||||
);
|
||||
}
|
||||
else {
|
||||
if ( exists $href->{edns_details} ) {
|
||||
my $pkt = Zonemaster::LDNS::Packet->new("$name", $type, $href->{class} );
|
||||
$pkt->set_edns_present();
|
||||
|
||||
$pkt->do($flags{q{dnssec}});
|
||||
$pkt->edns_size($flags{q{edns_size}});
|
||||
|
||||
if ( exists $href->{edns_details}{version} ) {
|
||||
$pkt->edns_version($href->{edns_details}{version});
|
||||
}
|
||||
if ( exists $href->{edns_details}{z} ) {
|
||||
$pkt->edns_z($href->{edns_details}{z});
|
||||
}
|
||||
if ( exists $href->{edns_details}{rcode} ) {
|
||||
$pkt->edns_rcode($href->{edns_details}{rcode});
|
||||
}
|
||||
if ( exists $href->{edns_details}{data} ) {
|
||||
$pkt->edns_data($href->{edns_details}{data});
|
||||
}
|
||||
|
||||
$res = eval { $self->dns->query_with_pkt( $pkt ) };
|
||||
}
|
||||
else {
|
||||
$res = eval { $self->dns->query( "$name", $type, $href->{class} ) };
|
||||
}
|
||||
|
||||
if ( $@ ) {
|
||||
my $msg = "$@";
|
||||
my $trailing_info = " at ".__FILE__;
|
||||
|
||||
chomp( $msg );
|
||||
$msg =~ s/$trailing_info.*/\./;
|
||||
|
||||
Zonemaster::Engine->logger->add( LOOKUP_ERROR =>
|
||||
{ message => $msg, ns => "$self", domain => "$name", type => $type, class => $href->{class} } );
|
||||
|
||||
if ( not $href->{q{blacklisting_disabled}} and $type eq q{SOA} and $flags{q{edns_size}} == 0 ) {
|
||||
$self->blacklisted->{ $flags{usevc} } = 1;
|
||||
Zonemaster::Engine->logger->add( BLACKLISTING =>
|
||||
{ ns => "$self", proto => $flags{usevc} ? q{TCP} : q{UDP} } );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
push @{ $self->times }, ( time() - $before );
|
||||
|
||||
if ( $res ) {
|
||||
my $p = Zonemaster::Engine::Packet->new( { packet => $res } );
|
||||
my $size = length( $p->data );
|
||||
if ( $size > $EDNS_UDP_PAYLOAD_COMMON_LIMIT ) {
|
||||
my $command = sprintf q{dig @%s %s%s %s}, $self->address->short, $flags{dnssec} ? q{+dnssec } : q{},
|
||||
"$name", $type;
|
||||
Zonemaster::Engine->logger->add(
|
||||
PACKET_BIG => { size => $size, command => $command } );
|
||||
}
|
||||
Zonemaster::Engine->logger->add( EXTERNAL_RESPONSE => { packet => $p->string } );
|
||||
return $p;
|
||||
}
|
||||
else {
|
||||
Zonemaster::Engine->logger->add( EMPTY_RETURN => {} );
|
||||
return;
|
||||
}
|
||||
} ## end sub _query
|
||||
|
||||
sub string {
|
||||
return $_[0]->{_string};
|
||||
}
|
||||
|
||||
sub compare {
|
||||
my ( $self, $other, $reverse ) = @_;
|
||||
|
||||
return $self->string cmp $other->string;
|
||||
}
|
||||
|
||||
sub save {
|
||||
my ( $class, $filename ) = @_;
|
||||
|
||||
my $old = POSIX::setlocale( POSIX::LC_ALL, 'C' );
|
||||
my $json = JSON::PP->new->allow_blessed->convert_blessed;
|
||||
$json = $json->canonical( 1 );
|
||||
|
||||
open my $fh, '>', $filename or die "Cache save failed: $!";
|
||||
foreach my $name ( sort keys %object_cache ) {
|
||||
foreach my $addr ( sort keys %{ $object_cache{$name} } ) {
|
||||
say $fh "$name $addr " . $json->encode( $object_cache{$name}{$addr}->cache->data );
|
||||
}
|
||||
}
|
||||
|
||||
close $fh or die $!;
|
||||
|
||||
Zonemaster::Engine->logger->add( SAVED_NS_CACHE => { file => $filename } );
|
||||
|
||||
POSIX::setlocale( POSIX::LC_ALL, $old );
|
||||
return;
|
||||
}
|
||||
|
||||
sub restore {
|
||||
my ( $class, $filename ) = @_;
|
||||
|
||||
useall 'Zonemaster::LDNS::RR';
|
||||
my $decode = JSON::PP->new->filter_json_single_key_object(
|
||||
'Zonemaster::LDNS::Packet' => sub {
|
||||
my ( $ref ) = @_;
|
||||
## no critic (Modules::RequireExplicitInclusion)
|
||||
my $obj = Zonemaster::LDNS::Packet->new_from_wireformat( decode_base64( $ref->{data} ) );
|
||||
$obj->answerfrom( $ref->{answerfrom} );
|
||||
$obj->timestamp( $ref->{timestamp} );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
)->filter_json_single_key_object(
|
||||
'Zonemaster::Engine::Packet' => sub {
|
||||
my ( $ref ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Packet->new( { packet => $ref } );
|
||||
}
|
||||
);
|
||||
|
||||
my $cache_type = Zonemaster::Engine::Nameserver::Cache->get_cache_type( Zonemaster::Engine::Profile->effective );
|
||||
my $cache_class = Zonemaster::Engine::Nameserver::Cache->get_cache_class( $cache_type );
|
||||
|
||||
open my $fh, '<', $filename or die "Failed to open restore data file: $!\n";
|
||||
while ( my $line = <$fh> ) {
|
||||
my ( $name, $addr, $data ) = split( / /, $line, 3 );
|
||||
my $ref = $decode->decode( $data );
|
||||
my $ns = Zonemaster::Engine::Nameserver->new(
|
||||
{
|
||||
name => $name,
|
||||
address => Net::IP::XS->new($addr),
|
||||
cache => $cache_class->new( { data => $ref, address => Net::IP::XS->new( $addr ) } )
|
||||
}
|
||||
);
|
||||
}
|
||||
close $fh;
|
||||
|
||||
Zonemaster::Engine->logger->add( RESTORED_NS_CACHE => { file => $filename } );
|
||||
|
||||
return;
|
||||
} ## end sub restore
|
||||
|
||||
sub max_time {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return max( @{ $self->times } ) // 0;
|
||||
}
|
||||
|
||||
sub min_time {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return min( @{ $self->times } ) // 0;
|
||||
}
|
||||
|
||||
sub sum_time {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return sum( @{ $self->times } ) // 0;
|
||||
}
|
||||
|
||||
sub average_time {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return 0 if @{ $self->times } == 0;
|
||||
|
||||
return ( $self->sum_time / scalar( @{ $self->times } ) );
|
||||
}
|
||||
|
||||
sub median_time {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my @t = sort { $a <=> $b } @{ $self->times };
|
||||
my $c = scalar( @t );
|
||||
if ( $c == 0 ) {
|
||||
return 0;
|
||||
}
|
||||
elsif ( $c % 2 == 0 ) {
|
||||
return ( $t[ $c / 2 ] + $t[ ( $c / 2 ) - 1 ] ) / 2;
|
||||
}
|
||||
else {
|
||||
return $t[ int( $c / 2 ) ];
|
||||
}
|
||||
}
|
||||
|
||||
sub stddev_time {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $avg = $self->average_time;
|
||||
my $c = scalar( @{ $self->times } );
|
||||
|
||||
return 0 if $c == 0;
|
||||
|
||||
return sqrt( sum( map { ( $_ - $avg )**2 } @{ $self->times } ) / $c );
|
||||
}
|
||||
|
||||
sub all_known_nameservers {
|
||||
my @res;
|
||||
|
||||
foreach my $n ( values %object_cache ) {
|
||||
push @res, values %{$n};
|
||||
}
|
||||
|
||||
return @res;
|
||||
}
|
||||
|
||||
sub axfr {
|
||||
my ( $self, $domain, $callback, $class ) = @_;
|
||||
$class //= 'IN';
|
||||
|
||||
if ( Zonemaster::Engine::Profile->effective->get( q{no_network} ) ) {
|
||||
croak sprintf
|
||||
"External AXFR query for %s attempted to %s while running with no_network",
|
||||
$domain, $self->string;
|
||||
}
|
||||
|
||||
if ( $self->address->version == 4 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) ) {
|
||||
Zonemaster::Engine->logger->add( IPV4_BLOCKED => { ns => $self->string } );
|
||||
return;
|
||||
}
|
||||
|
||||
if ( $self->address->version == 6 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) {
|
||||
Zonemaster::Engine->logger->add( IPV6_BLOCKED => { ns => $self->string } );
|
||||
return;
|
||||
}
|
||||
|
||||
return $self->dns->axfr( $domain, $callback, $class );
|
||||
} ## end sub axfr
|
||||
|
||||
sub source_address {
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $src_address = Zonemaster::Engine::Profile->effective->get( "resolver.source" . Net::IP::XS::ip_get_version( $self->address->ip ) );
|
||||
|
||||
return $src_address eq '' ? undef : $src_address;
|
||||
}
|
||||
|
||||
sub empty_cache {
|
||||
%object_cache = ();
|
||||
%address_object_cache = ();
|
||||
%address_repr_cache = ();
|
||||
|
||||
Zonemaster::Engine::Nameserver::Cache::empty_cache();
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Nameserver - object representing a DNS nameserver
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $ns = Zonemaster::Engine::Nameserver->new({ name => 'ns.nic.se', address => '212.247.7.228' });
|
||||
my $p = $ns->query('www.iis.se', 'AAAA');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a very central object in the L<Zonemaster::Engine> framework. All DNS
|
||||
communications with the outside world pass through here, so we can do
|
||||
things like synthesizing and recording traffic. All the objects are
|
||||
also unique per name/IP pair, and creating a new one with an already
|
||||
existing pair will return the existing object instead of creating a
|
||||
new one. Queries and their responses are cached by IP address, so that
|
||||
a specific query will only be sent once to each address (even if there
|
||||
are multiple objects for that address with different names).
|
||||
|
||||
Class methods on this class allows saving and loading cache contents.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item name
|
||||
|
||||
A L<Zonemaster::Engine::DNSName> object holding the nameserver's name.
|
||||
|
||||
=item address
|
||||
|
||||
A L<Net::IP::XS> object holding the nameserver's address.
|
||||
|
||||
=item dns
|
||||
|
||||
The L<Zonemaster::LDNS> object used to actually send and receive DNS queries.
|
||||
|
||||
=item cache
|
||||
|
||||
A reference to a L<Zonemaster::Engine::Nameserver::Cache> object holding the cache of sent queries. Not meant for external use.
|
||||
|
||||
=item times
|
||||
|
||||
A reference to a list with elapsed time values for the queries made through this nameserver.
|
||||
|
||||
=item blacklisted
|
||||
|
||||
A reference to a hash used to prevent sending subsequent queries to the name server after specific queries have failed.
|
||||
|
||||
The mechanism will only trigger on no response from non-EDNS SOA queries and is protocol dependent (i.e. TCP/UDP). It can be disabled
|
||||
on a per query basis with L<blacklisting_disabled>, or globally with L<Zonemaster::Engine::Constants/$BLACKLISTING_ENABLED>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new object.
|
||||
|
||||
=item save($filename)
|
||||
|
||||
Save the entire object cache to the given filename, using the
|
||||
byte-order-independent Storable format.
|
||||
|
||||
=item restore($filename)
|
||||
|
||||
Replace the entire object cache with the contents of the named file.
|
||||
|
||||
=item all_known_nameservers()
|
||||
|
||||
Class method that returns a list of all nameserver objects in the global cache.
|
||||
|
||||
=item empty_cache()
|
||||
|
||||
Remove all cached nameserver objects and queries.
|
||||
|
||||
=back
|
||||
|
||||
=head1 INSTANCE METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item query($name, $type, $flagref)
|
||||
|
||||
Send a DNS query to the nameserver the object represents. C<$name> and C<$type> are the name and type that will be queried for (C<$type> defaults
|
||||
to 'A' if it's left undefined). C<$flagref> is a reference to a hash, the keys of which are flags and the values are their corresponding values.
|
||||
The available flags are as follows. All but 'class' and 'edns_details' directly correspond to methods in the L<Zonemaster::LDNS> object.
|
||||
|
||||
=over
|
||||
|
||||
=item class
|
||||
|
||||
Defaults to 'IN' if not set.
|
||||
|
||||
=item usevc
|
||||
|
||||
Send the query via TCP (only).
|
||||
|
||||
=item retrans
|
||||
|
||||
The retransmission interval.
|
||||
|
||||
=item dnssec
|
||||
|
||||
Set the DO flag in the query. Defaults to false.
|
||||
|
||||
If set to true, it becomes an EDNS query.
|
||||
Value overridden by C<edns_details{do}> (if also given). More details in L<edns_details> below.
|
||||
|
||||
=item debug
|
||||
|
||||
Set the debug flag in the resolver, producing output on STDERR as the query process proceeds.
|
||||
|
||||
=item recurse
|
||||
|
||||
Set the RD flag in the query.
|
||||
|
||||
=item timeout
|
||||
|
||||
Set the timeout for the outgoing sockets. May or may not be observed by the underlying network stack.
|
||||
|
||||
=item retry
|
||||
|
||||
Set the number of times the query is tried.
|
||||
|
||||
=item igntc
|
||||
|
||||
If set to true, incoming response packets with the TC flag set are not automatically retried over TCP.
|
||||
|
||||
=item fallback
|
||||
|
||||
If set to true, incoming response packets with the TC flag set fall back to EDNS and/or TCP.
|
||||
|
||||
=item blacklisting_disabled
|
||||
|
||||
If set to true, prevents a name server from being blacklisted.
|
||||
|
||||
=item edns_size
|
||||
|
||||
Set the EDNS0 UDP maximum size. The value must be comprised between 0 and 65535.
|
||||
Defaults to 0, or 512 if the query is a non-DNSSEC EDNS query, or 1232 if the query is a DNSSEC query.
|
||||
|
||||
Setting a value other than 0 will also implicitly enable EDNS for the query.
|
||||
Value overridden by C<edns_details-E<gt>{size}> (if also given). More details in L<edns_details> below.
|
||||
|
||||
=item edns_details
|
||||
|
||||
A hash. An empty hash or a hash with any keys below will enable EDNS for the query.
|
||||
|
||||
The currently supported keys are 'version', 'z', 'do', 'rcode', 'size' and 'data'.
|
||||
See L<Zonemaster::LDNS::Packet> for more details (key names prefixed with 'edns_').
|
||||
|
||||
Note that flag L<edns_size> also exists (see above) and has the same effect as C<edns_details-E<gt>{size}>, although the value of the
|
||||
latter will take precedence if both are given.
|
||||
|
||||
Similarly, note that flag L<dnssec> also exists (see above) and has the same effect as C<edns_details-E<gt>{do}>, although the value of the
|
||||
latter will take precedence if both are given.
|
||||
|
||||
=back
|
||||
|
||||
=item string()
|
||||
|
||||
Returns a string representation of the object. Normally this is just the name and IP address separated by a slash.
|
||||
|
||||
=item compare($other)
|
||||
|
||||
Used for overloading comparison operators.
|
||||
|
||||
=item sum_time()
|
||||
|
||||
Returns the total time spent sending queries and waiting for responses.
|
||||
|
||||
=item min_time()
|
||||
|
||||
Returns the shortest time spent on a query.
|
||||
|
||||
=item max_time()
|
||||
|
||||
Returns the longest time spent on a query.
|
||||
|
||||
=item average_time()
|
||||
|
||||
Returns the average time spent on queries.
|
||||
|
||||
=item median_time()
|
||||
|
||||
Returns the median query time.
|
||||
|
||||
=item stddev_time()
|
||||
|
||||
Returns the standard deviation for the whole set of query times.
|
||||
|
||||
=item add_fake_delegation($domain,$data)
|
||||
|
||||
Adds fake delegation information to this specific nameserver object. Takes the
|
||||
same arguments as the similarly named method in L<Zonemaster::Engine>. This is
|
||||
primarily used for internal information, and using it directly will likely give
|
||||
confusing results (but may be useful to model certain kinds of
|
||||
misconfigurations).
|
||||
|
||||
=item add_fake_ds($domain, $data)
|
||||
|
||||
Adds fake DS information to this nameserver object. Takes the same arguments as
|
||||
the similarly named method in L<Zonemaster::Engine>.
|
||||
|
||||
=item axfr( $domain, $callback, $class )
|
||||
|
||||
Does an AXFR for the requested domain from the nameserver. The callback
|
||||
function will be called once for each received RR, with that RR as its only
|
||||
argument. To continue getting more RRs, the callback must return a true value.
|
||||
If it returns a true value, the AXFR will be aborted. See L<Zonemaster::LDNS::axfr>
|
||||
for more details.
|
||||
|
||||
=item source_address()
|
||||
|
||||
my $src_address = source_address();
|
||||
|
||||
Returns the configured IPv4 or IPv6 source address to be used by the underlying DNS resolver for sending queries,
|
||||
or C<undef> if the source address is the empty string.
|
||||
|
||||
=item empty_cache()
|
||||
|
||||
Clears the caches of Zonemaster::Engine::Nameserver (name server names and IP addresses) and Zonemaster::Engine::Nameserver::Cache (query and response packets) objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
99
zonemaster-engine/lib/Zonemaster/Engine/Nameserver/Cache.pm
Normal file
99
zonemaster-engine/lib/Zonemaster/Engine/Nameserver/Cache.pm
Normal file
@@ -0,0 +1,99 @@
|
||||
package Zonemaster::Engine::Nameserver::Cache;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.4");
|
||||
|
||||
use Class::Accessor "antlers";
|
||||
|
||||
our %object_cache;
|
||||
|
||||
has 'data' => ( is => 'ro' );
|
||||
has 'address' => ( is => 'ro' );
|
||||
|
||||
sub get_cache_type {
|
||||
my ( $class, $profile ) = @_;
|
||||
my $cache_type = 'LocalCache';
|
||||
|
||||
my %cache_config = %{ $profile->get( 'cache' ) };
|
||||
|
||||
if ( exists $cache_config{'redis'} ) {
|
||||
$cache_type = 'RedisCache';
|
||||
}
|
||||
|
||||
return $cache_type;
|
||||
}
|
||||
|
||||
sub get_cache_class {
|
||||
my ( $class, $cache_type ) = @_;
|
||||
|
||||
my $cache_class = "Zonemaster::Engine::Nameserver::Cache::$cache_type";
|
||||
|
||||
require ( "$cache_class.pm" =~ s{::}{/}gr );
|
||||
$cache_class->import();
|
||||
|
||||
return $cache_class;
|
||||
}
|
||||
|
||||
sub empty_cache {
|
||||
%object_cache = ();
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Nameserver::Cache - shared caches for nameserver objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This class should not be used directly.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item address
|
||||
|
||||
A L<Net::IP::XS> object holding the nameserver's address.
|
||||
|
||||
=item data
|
||||
|
||||
A reference to a hash holding the cache of sent queries. Not meant for external use.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item get_cache_type()
|
||||
|
||||
my $cache_type = get_cache_type( Zonemaster::Engine::Profile->effective );
|
||||
|
||||
Get the cache type value from the profile, i.e. the name of the cache module to use.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Profile> object.
|
||||
|
||||
Returns a string.
|
||||
|
||||
=item get_cache_class()
|
||||
|
||||
my $cache_class = get_cache_class( 'LocalCache' );
|
||||
|
||||
Get the cache adapter class for the given database type.
|
||||
|
||||
Takes a string (cache database type).
|
||||
|
||||
Returns a string, or throws an exception if the cache adapter class cannot be loaded.
|
||||
|
||||
=item empty_cache()
|
||||
|
||||
Clear the cache.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,100 @@
|
||||
package Zonemaster::Engine::Nameserver::Cache::LocalCache;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.4");
|
||||
|
||||
use Carp qw( confess );
|
||||
use Scalar::Util qw( blessed );
|
||||
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::Engine::Nameserver::Cache;
|
||||
|
||||
use base qw( Zonemaster::Engine::Nameserver::Cache );
|
||||
|
||||
our $object_cache = \%Zonemaster::Engine::Nameserver::Cache::object_cache;
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
my $attrs = shift;
|
||||
|
||||
confess "Attribute \(address\) is required"
|
||||
if !exists $attrs->{address};
|
||||
|
||||
# Type coercions
|
||||
$attrs->{address} = Net::IP::XS->new( $attrs->{address} )
|
||||
if !blessed $attrs->{address} || !$attrs->{address}->isa( 'Net::IP::XS' );
|
||||
|
||||
# Type constraint
|
||||
confess "Argument must be coercible into a Net::IP::XS: address"
|
||||
if !$attrs->{address}->isa( 'Net::IP::XS' );
|
||||
confess "Argument must be a HASHREF: data"
|
||||
if exists $attrs->{data} && ref $attrs->{data} ne 'HASH';
|
||||
|
||||
# Default value
|
||||
$attrs->{data} //= {};
|
||||
|
||||
my $ip = $attrs->{address}->ip;
|
||||
if ( exists $object_cache->{ $ip } ) {
|
||||
Zonemaster::Engine->logger->add( CACHE_FETCHED => { ip => $ip } );
|
||||
return $object_cache->{ $ip };
|
||||
}
|
||||
|
||||
my $obj = Class::Accessor::new( $class, $attrs );
|
||||
|
||||
Zonemaster::Engine->logger->add( CACHE_CREATED => { ip => $ip } );
|
||||
$object_cache->{ $ip } = $obj;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub set_key {
|
||||
my ( $self, $idx, $packet ) = @_;
|
||||
$self->data->{$idx} = $packet;
|
||||
}
|
||||
|
||||
sub get_key {
|
||||
my ( $self, $idx ) = @_;
|
||||
|
||||
if ( exists $self->data->{$idx} ) {
|
||||
# cache hit
|
||||
return ( 1, $self->data->{$idx} );
|
||||
}
|
||||
return ( 0, undef );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Nameserver::LocalCache - local shared caches for nameserver objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This class should not be used directly.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
Subclass of L<Zonemaster::Engine::Nameserver::Cache>.
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new Cache object.
|
||||
|
||||
=item set_key($idx, $packet)
|
||||
|
||||
Store C<$packet> (data) with key C<$idx>.
|
||||
|
||||
=item get_key($idx)
|
||||
|
||||
Retrieve C<$packet> (data) at key C<$idx>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,182 @@
|
||||
package Zonemaster::Engine::Nameserver::Cache::RedisCache;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.0");
|
||||
|
||||
use Class::Accessor "antlers";
|
||||
use Time::HiRes qw[gettimeofday tv_interval];
|
||||
use List::Util qw( min );
|
||||
|
||||
use Zonemaster::LDNS::Packet;
|
||||
use Zonemaster::Engine::Packet;
|
||||
use Zonemaster::Engine::Profile;
|
||||
|
||||
use base qw( Zonemaster::Engine::Nameserver::Cache );
|
||||
|
||||
eval {
|
||||
use Data::MessagePack;
|
||||
use Redis;
|
||||
};
|
||||
|
||||
if ( $@ ) {
|
||||
die "Can't use the Redis cache. Make sure the Data::MessagePack and Redis modules are installed.\n";
|
||||
}
|
||||
|
||||
my $redis;
|
||||
my $config;
|
||||
our $object_cache = \%Zonemaster::Engine::Nameserver::Cache::object_cache;
|
||||
|
||||
my $REDIS_EXPIRE_DEFAULT = 300; # seconds
|
||||
|
||||
has 'redis' => ( is => 'ro' );
|
||||
has 'config' => ( is => 'ro' );
|
||||
|
||||
my $mp = Data::MessagePack->new();
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $params = shift;
|
||||
$params->{address} = $params->{address}->ip;
|
||||
if ( exists $object_cache->{ $params->{address} } ) {
|
||||
Zonemaster::Engine->logger->add( CACHE_FETCHED => { ip => $params->{address} } );
|
||||
return $object_cache->{ $params->{address} };
|
||||
} else {
|
||||
if (! defined $redis) {
|
||||
my $redis_config = Zonemaster::Engine::Profile->effective->get( q{cache} )->{'redis'};
|
||||
$redis = Redis->new(server => $redis_config->{server});
|
||||
$config = $redis_config;
|
||||
}
|
||||
$params->{redis} //= $redis;
|
||||
$params->{data} //= {};
|
||||
$params->{config} //= $config;
|
||||
$config->{expire} //= $REDIS_EXPIRE_DEFAULT;
|
||||
my $class = ref $proto || $proto;
|
||||
my $obj = Class::Accessor::new( $class, $params );
|
||||
|
||||
Zonemaster::Engine->logger->add( CACHE_CREATED => { ip => $params->{address} } );
|
||||
$object_cache->{ $params->{address} } = $obj;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
}
|
||||
|
||||
sub set_key {
|
||||
my ( $self, $hash, $packet ) = @_;
|
||||
my $key = "ns:" . $self->address . ":" . $hash;
|
||||
|
||||
# Never cache with answer, NXDOMAIN or NODATA longer than this.
|
||||
my $redis_expire = $self->{config}->{expire};
|
||||
|
||||
# If no response or response without answer or SOA in authority,
|
||||
# cache this many seconds (e.g. SERVFAIL or REFUSED).
|
||||
my $ttl_no_response = 1200;
|
||||
|
||||
my $ttl;
|
||||
|
||||
$self->data->{$hash} = $packet;
|
||||
if ( defined $packet ) {
|
||||
my $msg = $mp->pack({
|
||||
data => $packet->data,
|
||||
answerfrom => $packet->answerfrom,
|
||||
timestamp => $packet->timestamp,
|
||||
querytime => $packet->querytime,
|
||||
});
|
||||
if ( $packet->answer ) {
|
||||
my @rr = $packet->answer;
|
||||
$ttl = min( map { $_->ttl } @rr );
|
||||
}
|
||||
elsif ( $packet->authority ) {
|
||||
my @rr = $packet->authority;
|
||||
foreach my $r (@rr) {
|
||||
if ( $r->type eq 'SOA' ) {
|
||||
$ttl = $r->ttl;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ( defined( $ttl ) ) {
|
||||
$ttl = $ttl < $redis_expire ? $ttl : $redis_expire;
|
||||
} else {
|
||||
$ttl = $ttl_no_response;
|
||||
}
|
||||
|
||||
# Redis requires cache time to be greater than 0 to be stored.
|
||||
return if $ttl == 0;
|
||||
$self->redis->set( $key, $msg, 'EX', $ttl );
|
||||
} else {
|
||||
$self->redis->set( $key, '', 'EX', $ttl_no_response );
|
||||
}
|
||||
}
|
||||
|
||||
sub get_key {
|
||||
my ( $self, $hash ) = @_;
|
||||
my $key = "ns:" . $self->address . ":" . $hash;
|
||||
|
||||
if ( exists $self->data->{$hash} ) {
|
||||
Zonemaster::Engine->logger->add( MEMORY_CACHE_HIT => { hash => $hash } );
|
||||
return ( 1, $self->data->{$hash} );
|
||||
} elsif ( $self->redis->exists($key) ) {
|
||||
my $fetch_start_time = [ gettimeofday ];
|
||||
my $data = $self->redis->get( $key );
|
||||
Zonemaster::Engine->logger->add( REDIS_CACHE_HIT => { key => $key } );
|
||||
if ( not length($data) ) {
|
||||
$self->data->{$hash} = undef;
|
||||
} else {
|
||||
my $msg = $mp->unpack( $data );
|
||||
my $packet = Zonemaster::Engine::Packet->new({ packet => Zonemaster::LDNS::Packet->new_from_wireformat($msg->{data}) });
|
||||
$packet->answerfrom( $msg->{answerfrom} );
|
||||
$packet->timestamp( $msg->{timestamp} );
|
||||
$packet->querytime( $msg->{querytime} );
|
||||
|
||||
$self->data->{$hash} = $packet;
|
||||
}
|
||||
return ( 1, $self->data->{$hash} );
|
||||
}
|
||||
Zonemaster::Engine->logger->add( CACHE_MISS => { key => $key } );
|
||||
return ( 0, undef )
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Nameserver::Cache::RedisCache - global shared caches for nameserver objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This is a global caching layer.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
Subclass of L<Zonemaster::Engine::Nameserver::Cache>.
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new Cache object.
|
||||
|
||||
=item set_key($idx, $packet)
|
||||
|
||||
Store C<$packet> with key C<$idx>.
|
||||
|
||||
=item get_key($idx)
|
||||
|
||||
Retrieve C<$packet> (data) at key C<$idx>.
|
||||
|
||||
=back
|
||||
|
||||
Cache time is the shortest time of TTL in the DNS packet
|
||||
and cache.redis.expire in the profile. Default value of
|
||||
cache.redis.expire is 300 seconds.
|
||||
|
||||
If there is no TTL value to be used in the DNS packet
|
||||
(e.g. SERVFAIL or no response), then cache time is fixed
|
||||
to 1200 seconds instead.
|
||||
|
||||
=cut
|
||||
225
zonemaster-engine/lib/Zonemaster/Engine/Normalization.pm
Normal file
225
zonemaster-engine/lib/Zonemaster/Engine/Normalization.pm
Normal file
@@ -0,0 +1,225 @@
|
||||
package Zonemaster::Engine::Normalization;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use parent 'Exporter';
|
||||
|
||||
use utf8;
|
||||
use Carp;
|
||||
use Encode;
|
||||
use Readonly;
|
||||
use Try::Tiny;
|
||||
use Zonemaster::LDNS;
|
||||
|
||||
use Zonemaster::Engine::Normalization::Error;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Normalization - utility functions for names normalization
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Zonemaster::Engine::Normalization;
|
||||
|
||||
my ($errors, $final_domain) = normalize_name($domain);
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
=over
|
||||
=cut
|
||||
|
||||
|
||||
our @EXPORT = qw[ normalize_name ];
|
||||
our @EXPORT_OK = qw[ normalize_name normalize_label trim_space ];
|
||||
|
||||
Readonly my $ASCII => qr/^[[:ascii:]]+$/;
|
||||
Readonly my $VALID_ASCII => qr(^[A-Za-z0-9/_-]+$);
|
||||
|
||||
Readonly my $ASCII_FULL_STOP => "\x{002E}";
|
||||
Readonly my $ASCII_FULL_STOP_RE => qr/\x{002E}/;
|
||||
Readonly my %FULL_STOPS => (
|
||||
FULLWIDTH_FULL_STOP => q/\x{FF0E}/,
|
||||
IDEOGRAPHIC_FULL_STOP => q/\x{3002}/,
|
||||
HALFWIDTH_IDEOGRAPHIC_FULL_STOP => q/\x{FF61}/
|
||||
);
|
||||
Readonly my $FULL_STOPS_RE => (sub {
|
||||
my $re = '[' . (join '', values %FULL_STOPS) . ']';
|
||||
return qr/$re/;
|
||||
})->();
|
||||
Readonly my %WHITE_SPACES => (
|
||||
SPACE => q/\x{0020}/,
|
||||
CHARACTER_TABULATION => q/\x{0009}/,
|
||||
NO_BREAK_SPACE => q/\x{00A0}/,
|
||||
EN_QUAD => q/\x{2000}/,
|
||||
EM_QUAD => q/\x{2001}/,
|
||||
EN_SPACE => q/\x{2002}/,
|
||||
EM_SPACE => q/\x{2003}/,
|
||||
THREE_PER_EM_SPACE => q/\x{2004}/,
|
||||
FOUR_PER_EM_SPACE => q/\x{2005}/,
|
||||
SIX_PER_EM_SPACE => q/\x{2006}/,
|
||||
FIGURE_SPACE => q/\x{2007}/,
|
||||
PUNCTUATION_SPACE => q/\x{2008}/,
|
||||
THIN_SPACE => q/\x{2009}/,
|
||||
HAIR_SPACE => q/\x{200A}/,
|
||||
MEDIUM_MATHEMATICAL_SPACE => q/\x{205F}/,
|
||||
IDEOGRAPHIC_SPACE => q/\x{3000}/,
|
||||
OGHAM_SPACE_MARK => q/\x{1680}/,
|
||||
);
|
||||
Readonly my $WHITE_SPACES_RE => (sub {
|
||||
my $re = '[' . (join '', values %WHITE_SPACES) . ']';
|
||||
return qr/$re/;
|
||||
})->();
|
||||
Readonly my %AMBIGUOUS_CHARACTERS => (
|
||||
"LATIN CAPITAL LETTER I WITH DOT ABOVE" => q/\x{0130}/,
|
||||
);
|
||||
|
||||
|
||||
|
||||
=item normalize_label($label)
|
||||
|
||||
Normalize a single label from a domain name.
|
||||
|
||||
If the label is ASCII only, it is down cased, else it is converted according
|
||||
to IDNA2008.
|
||||
|
||||
Downcasing of upper case non-ASCII characters, normalization to the Unicode
|
||||
NFC format and conversion from U-label to A-label is performed by libidn2
|
||||
using L<Zonemaster::LDNS/to_idn($name, ...)>.
|
||||
|
||||
Returns a tuple C<($errors: ArrayRef[Zonemaster::Engine::Normalization::Error], $alabel: String)>.
|
||||
|
||||
In case of errors, the returned label will be undefined. If the method
|
||||
succeeded an empty error array is returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub normalize_label {
|
||||
my ( $label ) = @_;
|
||||
my @messages;
|
||||
|
||||
my $alabel = "";
|
||||
|
||||
if ( $label =~ $VALID_ASCII ) {
|
||||
$alabel = lc $label;
|
||||
} elsif ( $label =~ $ASCII ) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(INVALID_ASCII => {label => $label});
|
||||
|
||||
return \@messages, undef;
|
||||
} elsif ( Zonemaster::LDNS::has_idn ) {
|
||||
try {
|
||||
$alabel = Zonemaster::LDNS::to_idn($label);
|
||||
} catch {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(INVALID_U_LABEL => {label => $label});
|
||||
|
||||
return \@messages, undef;
|
||||
}
|
||||
} else {
|
||||
croak 'The domain name contains at least one non-ASCII character and this installation of Zonemaster has no support for IDNA.';
|
||||
}
|
||||
|
||||
if ( length($alabel) > 63 ) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(LABEL_TOO_LONG => {label => $label});
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
return \@messages, $alabel;
|
||||
}
|
||||
|
||||
=item trim_space($str)
|
||||
|
||||
Trim leading and trailing whitespace.
|
||||
|
||||
Implements the space trimming part of L<normalization document|https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/RequirementsAndNormalizationOfDomainNames.md>.
|
||||
|
||||
Returns a string.
|
||||
|
||||
=cut
|
||||
|
||||
sub trim_space {
|
||||
my ( $str ) = @_;
|
||||
|
||||
return $str =~ s/^${$WHITE_SPACES_RE}+|${WHITE_SPACES_RE}+$//gr;
|
||||
}
|
||||
|
||||
=item normalize_name($name)
|
||||
|
||||
Normalize a domain name.
|
||||
|
||||
Implements the normalization process, except the space trimming part, described
|
||||
in L<normalization document|https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/RequirementsAndNormalizationOfDomainNames.md>.
|
||||
|
||||
Returns a tuple C<($errors: ArrayRef[Zonemaster::Engine::Normalization::Error], $name: String)>.
|
||||
|
||||
In case of errors, the returned name will be undefined. If the method succeeded
|
||||
an empty error array is returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub normalize_name {
|
||||
my ( $uname ) = @_;
|
||||
my @messages;
|
||||
|
||||
if ( length($uname) == 0 ) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(EMPTY_DOMAIN_NAME => {});
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
foreach my $char_name ( keys %AMBIGUOUS_CHARACTERS ) {
|
||||
my $char = $AMBIGUOUS_CHARACTERS{$char_name};
|
||||
if ( $uname =~ m/${char}/) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(AMBIGUOUS_DOWNCASING => { unicode_name => $char_name });
|
||||
}
|
||||
}
|
||||
|
||||
if ( @messages ) {
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
$uname =~ s/${FULL_STOPS_RE}/${ASCII_FULL_STOP}/g;
|
||||
|
||||
if ( $uname eq $ASCII_FULL_STOP ) {
|
||||
return \@messages, $uname;
|
||||
}
|
||||
|
||||
if ( $uname =~ m/^${ASCII_FULL_STOP_RE}/ ) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(INITIAL_DOT => {});
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
if ( $uname =~ m/${ASCII_FULL_STOP_RE}{2,}/ ) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(REPEATED_DOTS => {});
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
$uname =~ s/${ASCII_FULL_STOP_RE}$//g;
|
||||
|
||||
my @labels = split $ASCII_FULL_STOP_RE, $uname;
|
||||
my @label_results = map { [ normalize_label($_) ] } @labels;
|
||||
my @label_errors = map { @{$_->[0]} } @label_results;
|
||||
|
||||
push @messages, @label_errors;
|
||||
|
||||
if ( @messages ) {
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
my @label_ok = map { $_->[1] } @label_results;
|
||||
|
||||
my $final_name = join '.', @label_ok;
|
||||
|
||||
if ( length($final_name) > 253 ) {
|
||||
push @messages, Zonemaster::Engine::Normalization::Error->new(DOMAIN_NAME_TOO_LONG => {});
|
||||
return \@messages, undef;
|
||||
}
|
||||
|
||||
return \@messages, $final_name;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
=cut
|
||||
|
||||
1;
|
||||
147
zonemaster-engine/lib/Zonemaster/Engine/Normalization/Error.pm
Normal file
147
zonemaster-engine/lib/Zonemaster/Engine/Normalization/Error.pm
Normal file
@@ -0,0 +1,147 @@
|
||||
package Zonemaster::Engine::Normalization::Error;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
use Readonly;
|
||||
use Locale::TextDomain qw[Zonemaster-Engine];
|
||||
|
||||
use overload '""' => \&string;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Normalization::Error - normalization error class
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Zonemaster::Engine::Normalization::Error;
|
||||
|
||||
my $error = Zonemaster::Engine::Normalization::Error->new(LABEL_TOO_LONG => {label => $label});
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
Readonly my %ERRORS => (
|
||||
AMBIGUOUS_DOWNCASING => {
|
||||
message => N__ 'Ambiguous downcasing of character "{unicode_name}" in the domain name. Use all lower case instead.',
|
||||
arguments => [ 'unicode_name' ]
|
||||
},
|
||||
DOMAIN_NAME_TOO_LONG => {
|
||||
message => N__ 'Domain name is too long (more than 253 characters with no final dot).',
|
||||
},
|
||||
EMPTY_DOMAIN_NAME => {
|
||||
message => N__ 'Domain name is empty.'
|
||||
},
|
||||
INITIAL_DOT => {
|
||||
message => N__ 'Domain name starts with dot.'
|
||||
},
|
||||
INVALID_ASCII => {
|
||||
message => N__ 'Domain name has an ASCII label ("{label}") with a character not permitted.',
|
||||
arguments => [ 'label' ]
|
||||
},
|
||||
INVALID_U_LABEL => {
|
||||
message => N__ 'Domain name has a non-ASCII label ("{label}") which is not a valid U-label.',
|
||||
arguments => [ 'label' ]
|
||||
},
|
||||
REPEATED_DOTS => {
|
||||
message => N__ 'Domain name has repeated dots.'
|
||||
},
|
||||
LABEL_TOO_LONG => {
|
||||
message => N__ 'Domain name has a label that is too long (more than 63 characters), "{label}".',
|
||||
arguments => [ 'label' ]
|
||||
},
|
||||
);
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item tag
|
||||
|
||||
The message tag associated to the error.
|
||||
|
||||
=item params
|
||||
|
||||
The error message parameters to use in the message string.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item new($tag, $params)
|
||||
|
||||
Creates and returns a new error object.
|
||||
This function will croak if there is a missing parameter for the given tag.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $proto, $tag, $params ) = @_;
|
||||
my $class = ref $proto || $proto;
|
||||
|
||||
if ( !exists $ERRORS{$tag} ) {
|
||||
croak 'Unknown error tag.';
|
||||
}
|
||||
|
||||
my $obj = { tag => $tag, params => {} };
|
||||
|
||||
if ( exists $ERRORS{$tag}->{arguments} ) {
|
||||
foreach my $arg ( @{$ERRORS{$tag}->{arguments}} ) {
|
||||
if ( !exists $params->{$arg} ) {
|
||||
croak "Missing arguments $arg.";
|
||||
}
|
||||
$obj->{params}->{$arg} = $params->{$arg};
|
||||
}
|
||||
}
|
||||
|
||||
return bless $obj, $class;
|
||||
}
|
||||
|
||||
|
||||
=item message
|
||||
|
||||
Returns the translated error message using the parameters given when creating the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub message {
|
||||
my ( $self ) = @_;
|
||||
return __x $ERRORS{$self->{tag}}->{message}, %{$self->{params}};
|
||||
}
|
||||
|
||||
|
||||
=item tag
|
||||
|
||||
Returns the message tag associated to the error.
|
||||
|
||||
=cut
|
||||
|
||||
sub tag {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $self->{tag};
|
||||
}
|
||||
|
||||
=item string
|
||||
|
||||
Returns a string representation of the error object. Equivalent to message().
|
||||
|
||||
=cut
|
||||
|
||||
sub string {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $self->message;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
322
zonemaster-engine/lib/Zonemaster/Engine/Overview.pod
Normal file
322
zonemaster-engine/lib/Zonemaster/Engine/Overview.pod
Normal file
@@ -0,0 +1,322 @@
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Overview - The Zonemaster Test Engine
|
||||
|
||||
=head1 INTRODUCTION
|
||||
|
||||
The Zonemaster system is a quality control tool for DNS zones, produced in cooperation between AFNIC and IIS (the top-level registries for respectively France and Sweden). It is a successor both to AFNIC's tool Zonecheck and IIS's tool DNSCheck, and is intended to be an improvement over both.
|
||||
|
||||
The system as a whole consists of the test engine and, as distributed by the project, two different front ends. One is a command-line interface intended for use by experienced technicians, and one is a web interface meant for use by anyone. This document only talks about the test engine.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 Brief overview
|
||||
|
||||
Conceptually, the test engine consists of a number of test implementation modules surrounded by a support framework. Anyone wanting to use Zonemaster to perform tests communicates with the framework from the "outside", and all modules implementing tests see the world entirely through the framework. Doing things this way lets us have features like the ability to test domains before they are published, to record entire test runs for later analysis and to make sure that test results are (as far as reality allows) predictable and repeatable.
|
||||
|
||||
=head2 For users of Zonemaster
|
||||
|
||||
If all you want to do is run tests, you need to care about four or five modules. L<Zonemaster::Engine> is the main access point to the framework, and it is via its methods that you set the configuration (if needed), request that tests be started and access the logger. The logger is where the test results end up, so that's pretty important. On top of those, you may want to use the L<Zonemaster::Engine::Translator> to turn the results into human-readable messages.
|
||||
|
||||
There are two ways that you can get the results of a test you've requested: the simple-but-inflexible way and the flexible-but-complex way.
|
||||
|
||||
The simple-but-inflexible way is that all the methods in L<Zonemaster::Engine> that run tests return lists of L<Zonemaster::Engine::Logger::Entry> objects. Those lists include all the results that the writer of the test module(s) considered important enough to return by default. The advantage of this method is that it is extremely easy to use. The following is a functional (if not very useful) way to run a full test and print the results from a command-line prompt:
|
||||
|
||||
perl -MZonemaster::Engine -E 'say "$_" for Zonemaster::Engine->new->test_zone("example.org")'
|
||||
|
||||
The main drawbacks of this method are that there is no choice about what
|
||||
messages to see, and it's entirely synchronous.
|
||||
The code that started the test does not get a chance to do anything at
|
||||
all until the whole test suite has finished, which may be several minutes later.
|
||||
|
||||
To get around those drawbacks there is the flexible-but-complex way,
|
||||
which consists of installing a callback that gets executed every time
|
||||
a message is logged.
|
||||
It's not that much more complicated, code-wise.
|
||||
The following example does roughly the same thing as the one above:
|
||||
|
||||
perl -MZonemaster::Engine -E 'Zonemaster::Engine->logger->callback(sub {say "$_[0]"}); Zonemaster::Engine->new->test_zone("example.org");'
|
||||
|
||||
If you try running those, you'll notice two main differences. First, the second variant prints results as they are generated. Second, it generates a B<lot> more output. On my machine right now, the first example gives me 94 lines of output. The second example gives me 17684.
|
||||
|
||||
You can do pretty much whatever you want with the message objects in the callback (including modifying them, although we don't promise that behavior will stay around). If the callback code throws an exception, and that exception is not a subclass of L<Zonemaster::Engine::Exception>, the callback will be removed. Note also that while the callback is running, the test engine itself is not. So think twice before you do potentially time-consuming tasks (like sticking the message in a database) in the callback. After waiting for responses from remote name servers (which usually stands for more than 90% of the time used), the result logging is the single most time-consuming task in a Zonemaster test run.
|
||||
|
||||
From here, you probably want to look at the documentation for L<Zonemaster::Engine>, L<Zonemaster::Engine::Logger>, L<Zonemaster::Engine::Logger::Entry>, L<Zonemaster::Engine::Profile> and L<Zonemaster::Engine::Translator>.
|
||||
|
||||
=head2 For developers of Zonemaster Test Modules
|
||||
|
||||
If you want to develop a test module of your own, the standard set of modules serve as examples.
|
||||
|
||||
As an entry point to the "inside" of the Zonemaster framework, you want to read L<Zonemaster::Engine::Zone> and follow references from there. Of particular interest after the L<Zone|Zonemaster::Engine::Zone> class should be the L<Zonemaster::Engine::Nameserver> and possibly L<Zonemaster::Engine::Recursor> classes.
|
||||
|
||||
If you do write your own test module, I would very much appreciate feedback on which parts were tricky to figure out, because I'm honestly not sure what I need to explain here. So please, if there's something that you think really needs to be written about, create an issue at L<https://github.com/zonemaster/zonemaster-engine/issues>.
|
||||
|
||||
=head2 For developers of the Zonemaster Test Framework
|
||||
|
||||
Random recommendations and advice. May be replaced with more coherent developer documentation in the future.
|
||||
|
||||
=over
|
||||
|
||||
=item
|
||||
|
||||
Stability, predictability and reliability are more important than performance.
|
||||
|
||||
=item
|
||||
|
||||
Don't forget that starting with Perl version 5.18, the order in which you get the keys out of a hash will be different every time the script is run. Get used to always writing C<sort keys %hash>.
|
||||
|
||||
=item
|
||||
|
||||
If two (or more) test modules implement the same (or very similar) thing, it should probably be extracted into the framework.
|
||||
|
||||
=item
|
||||
|
||||
The unit tests run against pre-recorded data, unless the environment variable C<ZONEMASTER_RECORD> is set to a (perl-)true value. In that case, it runs against the live DNS world and records all results for future use. Unfortunately this sometime means that some tests fail, when we were relying on seeing certain problems in certain domains, and those no longer look the same.
|
||||
|
||||
=item
|
||||
|
||||
The translation strings returned from a test module are used as keys in the GNU gettext system, so if you change anything in them don't forget to also change the translation C<.po> files in F<share>.
|
||||
|
||||
=item
|
||||
|
||||
Adding a new message tag is more work than it first looks, since it needs to be added to the test module metadata, the default profile and the translation system in order to be fully functional.
|
||||
|
||||
=back
|
||||
|
||||
=head1 REFERENCES
|
||||
|
||||
=over
|
||||
|
||||
=item L<https://github.com/zonemaster/zonemaster>
|
||||
|
||||
Main repository, holding among other things our test specifications.
|
||||
|
||||
=back
|
||||
|
||||
=head2 List of all RFCs referred to in the test specifications
|
||||
|
||||
=over
|
||||
|
||||
=item
|
||||
|
||||
L<RFC0822 "STANDARD FOR THE FORMAT OF ARPA INTERNET TEXT MESSAGES"|http://www.rfc-editor.org/info/rfc822>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC0919 "Broadcasting Internet Datagrams"|http://www.rfc-editor.org/info/rfc919>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC0952 "DoD Internet host table specification"|http://www.rfc-editor.org/info/rfc952>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1033 "Domain Administrators Operations Guide"|http://www.rfc-editor.org/info/rfc1033>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1034 "Domain names - concepts and facilities"|http://www.rfc-editor.org/info/rfc1034>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1035 "Domain names - implementation and specification"|http://www.rfc-editor.org/info/rfc1035>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1112 "Host extensions for IP multicasting"|http://www.rfc-editor.org/info/rfc1112>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1122 "Requirements for Internet Hosts - Communication Layers"|http://www.rfc-editor.org/info/rfc1122>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1123 "Requirements for Internet Hosts - Application and Support"|http://www.rfc-editor.org/info/rfc1123>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1912 "Common DNS Operational and Configuration Errors"|http://www.rfc-editor.org/info/rfc1912>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1918 "Address Allocation for Private Internets"|http://www.rfc-editor.org/info/rfc1918>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1930 "Guidelines for creation, selection, and registration of an Autonomous System (AS)"|http://www.rfc-editor.org/info/rfc1930>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1982 "Serial Number Arithmetic"|http://www.rfc-editor.org/info/rfc1982>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC1996 "A Mechanism for Prompt Notification of Zone Changes (DNS NOTIFY)"|http://www.rfc-editor.org/info/rfc1996>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2142 "Mailbox Names for Common Services, Roles and Functions"|http://www.rfc-editor.org/info/rfc2142>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2181 "Clarifications to the DNS Specification"|http://www.rfc-editor.org/info/rfc2181>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2182 "Selection and Operation of Secondary DNS Servers"|http://www.rfc-editor.org/info/rfc2182>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2308 "Negative Caching of DNS Queries (DNS NCACHE)"|http://www.rfc-editor.org/info/rfc2308>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2544 "Benchmarking Methodology for Network Interconnect Devices"|http://www.rfc-editor.org/info/rfc2544>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2671 "Extension Mechanisms for DNS (EDNS0)"|http://www.rfc-editor.org/info/rfc2671>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2822 "Internet Message Format"|http://www.rfc-editor.org/info/rfc2822>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2870 "Root Name Server Operational Requirements"|http://www.rfc-editor.org/info/rfc2870>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC2928 "Initial IPv6 Sub-TLA ID Assignments"|http://www.rfc-editor.org/info/rfc2928>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3056 "Connection of IPv6 Domains via IPv4 Clouds"|http://www.rfc-editor.org/info/rfc3056>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3068 "An Anycast Prefix for 6to4 Relay Routers"|http://www.rfc-editor.org/info/rfc3068>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3658 "Delegation Signer (DS) Resource Record (RR)"|http://www.rfc-editor.org/info/rfc3658>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3696 "Application Techniques for Checking and Transformation of Names"|http://www.rfc-editor.org/info/rfc3696>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3701 "6bone (IPv6 Testing Address Allocation) Phaseout"|http://www.rfc-editor.org/info/rfc3701>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3849 "IPv6 Address Prefix Reserved for Documentation"|http://www.rfc-editor.org/info/rfc3849>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC3927 "Dynamic Configuration of IPv4 Link-Local Addresses"|http://www.rfc-editor.org/info/rfc3927>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4034 "Resource Records for the DNS Security Extensions"|http://www.rfc-editor.org/info/rfc4034>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4035 "Protocol Modifications for the DNS Security Extensions"|http://www.rfc-editor.org/info/rfc4035>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4074 "Common Misbehavior Against DNS Queries for IPv6 Addresses"|http://www.rfc-editor.org/info/rfc4074>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4193 "Unique Local IPv6 Unicast Addresses"|http://www.rfc-editor.org/info/rfc4193>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4291 "IP Version 6 Addressing Architecture"|http://www.rfc-editor.org/info/rfc4291>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4343 "Domain Name System (DNS) Case Insensitivity Clarification"|http://www.rfc-editor.org/info/rfc4343>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4380 "Teredo: Tunneling IPv6 over UDP through Network Address Translations (NATs)"|http://www.rfc-editor.org/info/rfc4380>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC4843 "An IPv6 Prefix for Overlay Routable Cryptographic Hash Identifiers (ORCHID)"|http://www.rfc-editor.org/info/rfc4843>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5155 "DNS Security (DNSSEC) Hashed Authenticated Denial of Existence"|http://www.rfc-editor.org/info/rfc5155>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5156 "Special-Use IPv6 Addresses"|http://www.rfc-editor.org/info/rfc5156>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5180 "IPv6 Benchmarking Methodology for Network Interconnect Devices"|http://www.rfc-editor.org/info/rfc5180>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5321 "Simple Mail Transfer Protocol"|http://www.rfc-editor.org/info/rfc5321>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5358 "Preventing Use of Recursive Nameservers in Reflector Attacks"|http://www.rfc-editor.org/info/rfc5358>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5737 "IPv4 Address Blocks Reserved for Documentation"|http://www.rfc-editor.org/info/rfc5737>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5771 "IANA Guidelines for IPv4 Multicast Address Assignments"|http://www.rfc-editor.org/info/rfc5771>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5892 "The Unicode Code Points and Internationalized Domain Names for Applications (IDNA)"|http://www.rfc-editor.org/info/rfc5892>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC5936 "DNS Zone Transfer Protocol (AXFR)"|http://www.rfc-editor.org/info/rfc5936>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6052 "IPv6 Addressing of IPv4/IPv6 Translators"|http://www.rfc-editor.org/info/rfc6052>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6333 "Dual-Stack Lite Broadband Deployments Following IPv4 Exhaustion"|http://www.rfc-editor.org/info/rfc6333>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6598 "IANA-Reserved IPv4 Prefix for Shared Address Space"|http://www.rfc-editor.org/info/rfc6598>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6666 "A Discard Prefix for IPv6"|http://www.rfc-editor.org/info/rfc6666>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6781 "DNSSEC Operational Practices, Version 2"|http://www.rfc-editor.org/info/rfc6781>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6890 "Special-Purpose IP Address Registries"|http://www.rfc-editor.org/info/rfc6890>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC6891 "Extension Mechanisms for DNS (EDNS(0))"|http://www.rfc-editor.org/info/rfc6891>
|
||||
|
||||
=item
|
||||
|
||||
L<RFC7050 "Discovery of the IPv6 Prefix Used for IPv6 Address Synthesis"|http://www.rfc-editor.org/info/rfc7050>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
293
zonemaster-engine/lib/Zonemaster/Engine/Packet.pm
Normal file
293
zonemaster-engine/lib/Zonemaster/Engine/Packet.pm
Normal file
@@ -0,0 +1,293 @@
|
||||
package Zonemaster::Engine::Packet;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.5");
|
||||
|
||||
use Class::Accessor 'antlers';
|
||||
use Carp qw( confess );
|
||||
use Zonemaster::Engine::Util;
|
||||
|
||||
has 'packet' => (
|
||||
is => 'ro',
|
||||
isa => 'Zonemaster::LDNS::Packet',
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
my $attrs = shift;
|
||||
|
||||
my $packet = delete $attrs->{packet};
|
||||
if ( %$attrs ) {
|
||||
confess "unexpected arguments: " . join ', ', sort keys %$attrs;
|
||||
}
|
||||
|
||||
return Class::Accessor::new( $class, { packet => $packet } );
|
||||
}
|
||||
|
||||
sub timestamp { my ( $self, $time ) = @_; return $self->packet->timestamp( $time // () ); }
|
||||
sub querytime { my ( $self, $value ) = @_; return $self->packet->querytime( $value // () ); }
|
||||
sub id { my ( $self, $id ) = @_; return $self->packet->id( $id // () ); }
|
||||
sub opcode { my ( $self, $string ) = @_; return $self->packet->opcode( $string // () ); }
|
||||
sub rcode { my ( $self, $string ) = @_; return $self->packet->rcode( $string // () ); }
|
||||
sub edns_version { my ( $self, $version ) = @_; return $self->packet->edns_version( $version // () ); }
|
||||
|
||||
sub type { my ( $self ) = @_; return $self->packet->type; }
|
||||
sub string { my ( $self ) = @_; return $self->packet->string; }
|
||||
sub data { my ( $self ) = @_; return $self->packet->data; }
|
||||
sub aa { my ( $self ) = @_; return $self->packet->aa; }
|
||||
sub do { my ( $self ) = @_; return $self->packet->do; }
|
||||
sub ra { my ( $self ) = @_; return $self->packet->ra; }
|
||||
sub tc { my ( $self ) = @_; return $self->packet->tc; }
|
||||
sub question { my ( $self ) = @_; return $self->packet->question; }
|
||||
sub authority { my ( $self ) = @_; return $self->packet->authority; }
|
||||
sub answer { my ( $self ) = @_; return $self->packet->answer; }
|
||||
sub additional { my ( $self ) = @_; return $self->packet->additional; }
|
||||
sub edns_size { my ( $self ) = @_; return $self->packet->edns_size; }
|
||||
sub edns_rcode { my ( $self ) = @_; return $self->packet->edns_rcode; }
|
||||
sub edns_data { my ( $self ) = @_; return $self->packet->edns_data; }
|
||||
sub edns_z { my ( $self ) = @_; return $self->packet->edns_z; }
|
||||
sub has_edns { my ( $self ) = @_; return $self->packet->has_edns; }
|
||||
|
||||
sub unique_push {
|
||||
my ( $self, $section, $rr ) = @_;
|
||||
return $self->packet->unique_push( $section, $rr );
|
||||
}
|
||||
|
||||
sub no_such_record {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->type eq 'nodata' ) {
|
||||
my ( $q ) = $self->question;
|
||||
Zonemaster::Engine::Util::info( NO_SUCH_RECORD => { name => Zonemaster::Engine::Util::name( $q->name ), type => $q->type } );
|
||||
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub no_such_name {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->type eq 'nxdomain' ) {
|
||||
my ( $q ) = $self->question;
|
||||
info( NO_SUCH_NAME => { name => name( $q->name ), type => $q->type } );
|
||||
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub is_redirect {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->type eq 'referral' ) {
|
||||
my ( $q ) = $self->question;
|
||||
my ( $a ) = $self->authority;
|
||||
Zonemaster::Engine::Util::info(
|
||||
IS_REDIRECT => {
|
||||
name => Zonemaster::Engine::DNSName->from_string( $q->name ),
|
||||
type => $q->type,
|
||||
to => Zonemaster::Engine::DNSName->from_string( $a->name )
|
||||
}
|
||||
);
|
||||
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
} ## end sub is_redirect
|
||||
|
||||
sub get_records {
|
||||
my ( $self, $type, @section ) = @_;
|
||||
@section = qw(answer authority additional) if !@section;
|
||||
my %sec = map { lc( $_ ) => 1 } @section;
|
||||
my @raw;
|
||||
$type = uc( $type );
|
||||
|
||||
if ( $sec{'answer'} ) {
|
||||
push @raw, grep { $_->type eq $type } $self->packet->answer;
|
||||
}
|
||||
|
||||
if ( $sec{'authority'} ) {
|
||||
push @raw, grep { $_->type eq $type } $self->packet->authority;
|
||||
}
|
||||
|
||||
if ( $sec{'additional'} ) {
|
||||
push @raw, grep { $_->type eq $type } $self->packet->additional;
|
||||
}
|
||||
|
||||
return @raw;
|
||||
} ## end sub get_records
|
||||
|
||||
sub get_records_for_name {
|
||||
my ( $self, $type, $name, @section ) = @_;
|
||||
|
||||
# Make sure $name is a Zonemaster::Engine::DNSName
|
||||
$name = name( $name );
|
||||
|
||||
return grep { name( $_->name ) eq $name } $self->get_records( $type, @section );
|
||||
}
|
||||
|
||||
sub has_rrs_of_type_for_name {
|
||||
my ( $self, $type, $name, @section ) = @_;
|
||||
|
||||
# Make sure $name is a Zonemaster::Engine::DNSName
|
||||
$name = name( $name );
|
||||
|
||||
return ( grep { name( $_->name ) eq $name } $self->get_records( $type, @section ) ) > 0;
|
||||
}
|
||||
|
||||
sub answerfrom {
|
||||
my ( $self, @args ) = @_;
|
||||
|
||||
if ( @args ) {
|
||||
$self->packet->answerfrom( @args );
|
||||
}
|
||||
|
||||
my $from = $self->packet->answerfrom // '<unknown>';
|
||||
|
||||
return $from;
|
||||
}
|
||||
|
||||
sub TO_JSON {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return { 'Zonemaster::Engine::Packet' => $self->packet };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Packet - wrapping object for L<Zonemaster::LDNS::Packet> objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $packet = $ns->query('iis.se', 'NS');
|
||||
my @rrs = $packet->get_records('ns');
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item packet
|
||||
|
||||
Holds the L<Zonemaster::LDNS::Packet> the object is wrapping.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new instance.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item no_such_record
|
||||
|
||||
Returns true if the packet represents an existing DNS node lacking any records of the requested type.
|
||||
|
||||
=item no_such_name
|
||||
|
||||
Returns true if the packet represents a nonexistent DNS node.
|
||||
|
||||
=item is_redirect
|
||||
|
||||
Returns true if the packet is a redirect to another set of nameservers.
|
||||
|
||||
=item get_records($type[, @section])
|
||||
|
||||
Returns the L<Zonemaster::LDNS::RR> objects of the requested type in the packet.
|
||||
If the optional C<@section> argument is given, and is a list of C<answer>,
|
||||
C<authority> and C<additional>, only RRs from those sections are returned.
|
||||
|
||||
=item get_records_for_name($type, $name[, @section])
|
||||
|
||||
Returns all L<Zonemaster::LDNS::RR> objects for the given name in the packet.
|
||||
If the optional C<@section> argument is given, and is a list of C<answer>,
|
||||
C<authority> and C<additional>, only RRs from those sections are returned.
|
||||
|
||||
=item has_rrs_of_type_for_name($type, $name[, @section])
|
||||
|
||||
Returns true if the packet holds any RRs of the specified type for the given name.
|
||||
If the optional C<@section> argument is given, and is a list of C<answer>,
|
||||
C<authority> and C<additional>, only RRs from those sections are returned.
|
||||
|
||||
=item answerfrom
|
||||
|
||||
Wrapper for the underlying packet method, that replaces undefined values with the string C<E<lt>unknownE<gt>>.
|
||||
|
||||
=item TO_JSON
|
||||
|
||||
Support method for L<JSON> to be able to serialize these objects.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS PASSED THROUGH
|
||||
|
||||
These methods are passed through transparently to the underlying L<Zonemaster::LDNS::Packet> object.
|
||||
|
||||
=over
|
||||
|
||||
=item data
|
||||
|
||||
=item rcode
|
||||
|
||||
=item aa
|
||||
|
||||
=item ra
|
||||
|
||||
=item tc
|
||||
|
||||
=item question
|
||||
|
||||
=item answer
|
||||
|
||||
=item authority
|
||||
|
||||
=item additional
|
||||
|
||||
=item string
|
||||
|
||||
=item unique_push
|
||||
|
||||
=item timestamp
|
||||
|
||||
=item type
|
||||
|
||||
=item edns_size
|
||||
|
||||
=item edns_rcode
|
||||
|
||||
=item edns_version
|
||||
|
||||
=item edns_z
|
||||
|
||||
=item edns_data
|
||||
|
||||
=item has_edns
|
||||
|
||||
=item id
|
||||
|
||||
=item querytime
|
||||
|
||||
=item do
|
||||
|
||||
=item opcode
|
||||
|
||||
=back
|
||||
973
zonemaster-engine/lib/Zonemaster/Engine/Profile.pm
Normal file
973
zonemaster-engine/lib/Zonemaster/Engine/Profile.pm
Normal file
@@ -0,0 +1,973 @@
|
||||
package Zonemaster::Engine::Profile;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare( "v1.2.22" );
|
||||
|
||||
use File::ShareDir qw[dist_file];
|
||||
use JSON::PP qw( encode_json decode_json );
|
||||
use Scalar::Util qw(reftype looks_like_number);
|
||||
use File::Slurp;
|
||||
use Clone qw(clone);
|
||||
use Data::Dumper;
|
||||
use Net::IP::XS;
|
||||
use Log::Any qw( $log );
|
||||
use YAML::XS qw();
|
||||
|
||||
$YAML::XS::Boolean = "JSON::PP";
|
||||
|
||||
use Zonemaster::Engine::Constants qw( $DURATION_5_MINUTES_IN_SECONDS $DURATION_1_HOUR_IN_SECONDS $DURATION_4_HOURS_IN_SECONDS $DURATION_12_HOURS_IN_SECONDS $DURATION_1_DAY_IN_SECONDS $DURATION_1_WEEK_IN_SECONDS $DURATION_180_DAYS_IN_SECONDS );
|
||||
use Zonemaster::Engine::Validation qw( validate_ipv4 validate_ipv6 );
|
||||
|
||||
my %profile_properties_details = (
|
||||
q{cache} => {
|
||||
type => q{HashRef},
|
||||
test => sub {
|
||||
my @allowed_keys = ( 'redis' );
|
||||
foreach my $cache_database ( keys %{$_[0]} ) {
|
||||
if ( not grep( /^$cache_database$/, @allowed_keys ) ) {
|
||||
die "Property cache keys have " . scalar @allowed_keys . " possible values: " . join(", ", @allowed_keys) . "\n";
|
||||
}
|
||||
|
||||
if ( not scalar keys %{ $_[0]->{$cache_database} } ) {
|
||||
die "Property cache.$cache_database has no items\n";
|
||||
}
|
||||
else {
|
||||
my @allowed_subkeys;
|
||||
if ( $cache_database eq 'redis' ) {
|
||||
@allowed_subkeys = ( 'server', 'expire' );
|
||||
}
|
||||
|
||||
foreach my $key ( keys %{ $_[0]->{$cache_database} } ) {
|
||||
if ( not grep( /^$key$/, @allowed_subkeys ) ) {
|
||||
die "Property cache.$cache_database subkeys have " . scalar @allowed_subkeys . " possible values: " . join(", ", @allowed_subkeys) . "\n";
|
||||
}
|
||||
|
||||
die "Property cache.$cache_database.$key has a NULL or empty item\n" if not $_[0]->{$cache_database}->{$key};
|
||||
die "Property cache.$cache_database.$key has a negative value\n" if ( looks_like_number( $_[0]->{$cache_database}->{$key} ) and $_[0]->{$cache_database}->{$key} < 0 ) ;
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
default => {},
|
||||
},
|
||||
q{resolver.defaults.debug} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{resolver.defaults.igntc} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{resolver.defaults.fallback} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{resolver.defaults.recurse} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{resolver.defaults.retrans} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
max => 255
|
||||
},
|
||||
q{resolver.defaults.retry} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
max => 255
|
||||
},
|
||||
q{resolver.defaults.usevc} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{resolver.defaults.timeout} => {
|
||||
type => q{Num}
|
||||
},
|
||||
q{resolver.source4} => {
|
||||
type => q{Str},
|
||||
test => sub {
|
||||
unless ( $_[0] eq '' or validate_ipv4( $_[0] ) ) {
|
||||
die "Property resolver.source4 must be an IPv4 address or the empty string\n";
|
||||
}
|
||||
},
|
||||
default => q{}
|
||||
},
|
||||
q{resolver.source6} => {
|
||||
type => q{Str},
|
||||
test => sub {
|
||||
unless ( $_[0] eq '' or validate_ipv6( $_[0] ) ) {
|
||||
die "Property resolver.source6 must be a valid IPv6 address or the empty string\n";
|
||||
}
|
||||
},
|
||||
default => q{}
|
||||
},
|
||||
q{net.ipv4} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{net.ipv6} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{no_network} => {
|
||||
type => q{Bool}
|
||||
},
|
||||
q{asn_db.style} => {
|
||||
type => q{Str},
|
||||
test => sub {
|
||||
if ( lc($_[0]) ne q{cymru} and lc($_[0]) ne q{ripe} ) {
|
||||
die "Property asn_db.style has 2 possible values : Cymru or RIPE (case-insensitive)\n";
|
||||
}
|
||||
$_[0] = lc($_[0]);
|
||||
},
|
||||
default => q{cymru}
|
||||
},
|
||||
q{asn_db.sources} => {
|
||||
type => q{HashRef},
|
||||
test => sub {
|
||||
foreach my $db_style ( keys %{$_[0]} ) {
|
||||
if ( lc($db_style) ne q{cymru} and lc($db_style) ne q{ripe} ) {
|
||||
die "Property asn_db.sources keys have 2 possible values : Cymru or RIPE (case-insensitive)\n";
|
||||
}
|
||||
if ( not scalar @{ ${$_[0]}{$db_style} } ) {
|
||||
die "Property asn_db.sources.$db_style has no items\n";
|
||||
}
|
||||
else {
|
||||
foreach my $ndd ( @{ ${$_[0]}{$db_style} } ) {
|
||||
die "Property asn_db.sources.$db_style has a NULL item\n" if not defined $ndd;
|
||||
die "Property asn_db.sources.$db_style has a non scalar item\n" if not defined ref($ndd);
|
||||
die "Property asn_db.sources.$db_style has an item too long\n" if length($ndd) > 255;
|
||||
foreach my $label ( split /[.]/, $ndd ) {
|
||||
die "Property asn_db.sources.$db_style has a non domain name item\n" if $label !~ /^[a-z0-9](?:[-a-z0-9]{0,61}[a-z0-9])?$/;
|
||||
}
|
||||
}
|
||||
${$_[0]}{lc($db_style)} = delete ${$_[0]}{$db_style};
|
||||
}
|
||||
}
|
||||
},
|
||||
default => { cymru => [ "asnlookup.zonemaster.net" ] },
|
||||
},
|
||||
q{logfilter} => {
|
||||
type => q{HashRef},
|
||||
default => {}
|
||||
},
|
||||
q{test_levels} => {
|
||||
type => q{HashRef}
|
||||
},
|
||||
q{test_cases} => {
|
||||
type => q{ArrayRef}
|
||||
},
|
||||
q{test_cases_vars.dnssec04.REMAINING_SHORT} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_12_HOURS_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.dnssec04.REMAINING_LONG} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_180_DAYS_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.dnssec04.DURATION_LONG} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_180_DAYS_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.zone02.SOA_REFRESH_MINIMUM_VALUE} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_4_HOURS_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.zone04.SOA_RETRY_MINIMUM_VALUE} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_1_HOUR_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.zone05.SOA_EXPIRE_MINIMUM_VALUE} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_1_WEEK_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.zone06.SOA_DEFAULT_TTL_MAXIMUM_VALUE} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_1_DAY_IN_SECONDS
|
||||
},
|
||||
q{test_cases_vars.zone06.SOA_DEFAULT_TTL_MINIMUM_VALUE} => {
|
||||
type => q{Num},
|
||||
min => 1,
|
||||
default => $DURATION_5_MINUTES_IN_SECONDS
|
||||
}
|
||||
);
|
||||
|
||||
_init_profile_properties_details_defaults();
|
||||
|
||||
sub _init_profile_properties_details_defaults {
|
||||
my $default_file = dist_file( 'Zonemaster-Engine', 'profile.json');
|
||||
my $json = read_file( $default_file );
|
||||
my $default_values = decode_json( $json );
|
||||
foreach my $property_name ( keys %profile_properties_details ) {
|
||||
if ( defined _get_value_from_nested_hash( $default_values, split /[.]/, $property_name ) ) {
|
||||
$profile_properties_details{$property_name}{default} = clone _get_value_from_nested_hash( $default_values, split /[.]/, $property_name );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_profile_paths {
|
||||
my ( $paths_ref, $data, @path ) = @_;
|
||||
|
||||
foreach my $key (sort keys %$data) {
|
||||
|
||||
my $path = join '.', @path, $key;
|
||||
if (ref($data->{$key}) eq 'HASH' and not exists $profile_properties_details{$path} ) {
|
||||
_get_profile_paths($paths_ref, $data->{$key}, @path, $key);
|
||||
next;
|
||||
}
|
||||
else {
|
||||
$paths_ref->{$path} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_value_from_nested_hash {
|
||||
my ( $hash_ref, @path ) = @_;
|
||||
|
||||
my $key = shift @path;
|
||||
if ( exists $hash_ref->{$key} ) {
|
||||
if ( @path ) {
|
||||
my $value_type = reftype($hash_ref->{$key});
|
||||
if ( $value_type eq q{HASH} ) {
|
||||
return _get_value_from_nested_hash( $hash_ref->{$key}, @path );
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return $hash_ref->{$key};
|
||||
}
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub _set_value_to_nested_hash {
|
||||
my ( $hash_ref, $value, @path ) = @_;
|
||||
|
||||
my $key = shift @path;
|
||||
|
||||
if ( ! exists $hash_ref->{$key} ) {
|
||||
$hash_ref->{$key} = {};
|
||||
}
|
||||
if ( @path ) {
|
||||
_set_value_to_nested_hash( $hash_ref->{$key}, $value, @path );
|
||||
}
|
||||
else {
|
||||
$hash_ref->{$key} = clone $value;
|
||||
}
|
||||
}
|
||||
|
||||
our $effective = Zonemaster::Engine::Profile->default;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
$self->{q{profile}} = {};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub default {
|
||||
my ( $class ) = @_;
|
||||
my $new = $class->new;
|
||||
foreach my $property_name ( keys %profile_properties_details ) {
|
||||
if ( exists $profile_properties_details{$property_name}{default} ) {
|
||||
$new->set( $property_name, $profile_properties_details{$property_name}{default} );
|
||||
}
|
||||
}
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub all_properties {
|
||||
my ( $class ) = @_;
|
||||
return sort keys %profile_properties_details;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my ( $self, $property_name ) = @_;
|
||||
|
||||
die "Unknown property '$property_name'\n" if not exists $profile_properties_details{$property_name};
|
||||
|
||||
if ( $profile_properties_details{$property_name}->{type} eq q{ArrayRef} or $profile_properties_details{$property_name}->{type} eq q{HashRef} ) {
|
||||
return clone _get_value_from_nested_hash( $self->{q{profile}}, split /[.]/, $property_name );
|
||||
} else {
|
||||
return _get_value_from_nested_hash( $self->{q{profile}}, split /[.]/, $property_name );
|
||||
}
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ( $self, $property_name, $value ) = @_;
|
||||
|
||||
$self->_set( q{DIRECT}, $property_name, $value );
|
||||
}
|
||||
|
||||
sub _set {
|
||||
my ( $self, $from, $property_name, $value ) = @_;
|
||||
my $value_type = reftype($value);
|
||||
my $data_details;
|
||||
|
||||
die "Unknown property '$property_name'\n" if not exists $profile_properties_details{$property_name};
|
||||
|
||||
$data_details = sprintf "[TYPE=%s][FROM=%s][VALUE_TYPE=%s][VALUE=%s]\n%s",
|
||||
exists $profile_properties_details{$property_name}->{type} ? $profile_properties_details{$property_name}->{type} : q{UNDEF},
|
||||
defined $from ? $from : q{UNDEF},
|
||||
defined $value_type ? $value_type : q{UNDEF},
|
||||
defined $value ? $value : q{[UNDEF]},
|
||||
Data::Dumper::Dumper($value);
|
||||
# $value is a Scalar
|
||||
if ( ! $value_type or $value_type eq q{SCALAR} ) {
|
||||
die "Property $property_name can not be undef\n" if not defined $value;
|
||||
|
||||
# Boolean
|
||||
if ( $profile_properties_details{$property_name}->{type} eq q{Bool} ) {
|
||||
if ( $from eq q{DIRECT} and !$value ) {
|
||||
$value = JSON::PP::false;
|
||||
}
|
||||
elsif ( $from eq q{DIRECT} and $value ) {
|
||||
$value = JSON::PP::true;
|
||||
}
|
||||
elsif ( $from eq q{JSON} and $value_type and $value == JSON::PP::false ) {
|
||||
$value = JSON::PP::false;
|
||||
}
|
||||
elsif ( $from eq q{JSON} and $value_type and $value == JSON::PP::true ) {
|
||||
$value = JSON::PP::true;
|
||||
}
|
||||
else {
|
||||
die "Property $property_name is of type Boolean $data_details\n";
|
||||
}
|
||||
}
|
||||
# Number. In our case, only non-negative integers
|
||||
elsif ( $profile_properties_details{$property_name}->{type} eq q{Num} ) {
|
||||
if ( $value !~ /^(\d+)$/ ) {
|
||||
die "Property $property_name is of type non-negative integer $data_details\n";
|
||||
}
|
||||
if ( exists $profile_properties_details{$property_name}->{min} and $value < $profile_properties_details{$property_name}->{min} ) {
|
||||
die "Property $property_name value is out of limit (smaller)\n";
|
||||
}
|
||||
if ( exists $profile_properties_details{$property_name}->{max} and $value > $profile_properties_details{$property_name}->{max} ) {
|
||||
die "Property $property_name value is out of limit (bigger)\n";
|
||||
}
|
||||
|
||||
$value = 0+ $value; # Make sure JSON::PP doesn't serialize it as a JSON string
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Array
|
||||
if ( $profile_properties_details{$property_name}->{type} eq q{ArrayRef} and reftype($value) ne q{ARRAY} ) {
|
||||
die "Property $property_name is not a ArrayRef $data_details\n";
|
||||
}
|
||||
# Hash
|
||||
elsif ( $profile_properties_details{$property_name}->{type} eq q{HashRef} and reftype($value) ne q{HASH} ) {
|
||||
die "Property $property_name is not a HashRef $data_details\n";
|
||||
}
|
||||
elsif ( $profile_properties_details{$property_name}->{type} eq q{Bool} or $profile_properties_details{$property_name}->{type} eq q{Num} or $profile_properties_details{$property_name}->{type} eq q{Str} ) {
|
||||
die "Property $property_name is a Scalar $data_details\n";
|
||||
}
|
||||
}
|
||||
|
||||
if ( $profile_properties_details{$property_name}->{test} ) {
|
||||
$profile_properties_details{$property_name}->{test}->( $value );
|
||||
}
|
||||
|
||||
return _set_value_to_nested_hash( $self->{q{profile}}, $value, split /[.]/, $property_name );
|
||||
}
|
||||
|
||||
sub merge {
|
||||
my ( $self, $other_profile ) = @_;
|
||||
|
||||
die "Merge with ", __PACKAGE__, " only\n" if ref($other_profile) ne __PACKAGE__;
|
||||
|
||||
foreach my $property_name ( keys %profile_properties_details ) {
|
||||
if ( defined _get_value_from_nested_hash( $other_profile->{q{profile}}, split /[.]/, $property_name ) ) {
|
||||
$self->_set( q{JSON}, $property_name, _get_value_from_nested_hash( $other_profile->{q{profile}}, split /[.]/, $property_name ) );
|
||||
}
|
||||
}
|
||||
|
||||
return $other_profile->{q{profile}};
|
||||
}
|
||||
|
||||
sub from_json {
|
||||
my ( $class, $json ) = @_;
|
||||
my $new = $class->new;
|
||||
my $internal = decode_json( $json );
|
||||
my %paths;
|
||||
_get_profile_paths(\%paths, $internal);
|
||||
foreach my $property_name ( keys %paths ) {
|
||||
if ( defined _get_value_from_nested_hash( $internal, split /[.]/, $property_name ) ) {
|
||||
$new->_set( q{JSON}, $property_name, _get_value_from_nested_hash( $internal, split /[.]/, $property_name ) );
|
||||
}
|
||||
}
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub to_json {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return encode_json( $self->{q{profile}} );
|
||||
}
|
||||
|
||||
sub from_yaml {
|
||||
my ( $class, $yaml ) = @_;
|
||||
my $data = YAML::XS::Load( $yaml );
|
||||
return $class->from_json( encode_json( $data ) );
|
||||
}
|
||||
|
||||
sub to_yaml {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return YAML::XS::Dump( $self->{q{profile}} );
|
||||
}
|
||||
|
||||
sub effective {
|
||||
return $effective;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Profile - A simple system for configuring Zonemaster Engine
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This module has two parts:
|
||||
|
||||
=over
|
||||
|
||||
=item * a I<profile> representation class
|
||||
|
||||
=item * a global profile object (the I<effective profile>) that configures Zonemaster Engine
|
||||
|
||||
=back
|
||||
|
||||
A I<profile> consists of a collection of named properties.
|
||||
|
||||
The properties determine the configurable behaviors of Zonemaster
|
||||
Engine with regard to what tests are to be performed, how they are to
|
||||
be performed, and how the results are to be analyzed.
|
||||
For details on available properties see the L</PROFILE PROPERTIES>
|
||||
section.
|
||||
|
||||
Here is an example for updating the effective profile with values from
|
||||
a given file and setting all properties not mentioned in the file to
|
||||
default values.
|
||||
For details on the file format see the L</REPRESENTATIONS> section.
|
||||
|
||||
use Zonemaster::Engine::Profile;
|
||||
|
||||
my $json = read_file( "/path/to/foo.profile" );
|
||||
my $foo = Zonemaster::Engine::Profile->from_json( $json );
|
||||
my $profile = Zonemaster::Engine::Profile->default;
|
||||
$profile->merge( $foo );
|
||||
Zonemaster::Engine::Profile->effective->merge( $profile );
|
||||
|
||||
Here is an example for serializing the default profile to JSON.
|
||||
|
||||
my $string = Zonemaster::Engine::Profile->default->to_json;
|
||||
|
||||
For any given profile:
|
||||
|
||||
=over
|
||||
|
||||
=item * At any moment, each property is either set or unset.
|
||||
|
||||
=item * At any moment, every set property has a valid value.
|
||||
|
||||
=item * It is possible to set the value of each unset property.
|
||||
|
||||
=item * It is possible to update the value of each set property.
|
||||
|
||||
=item * It is NOT possible to unset the value of any set property.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CLASS ATTRIBUTES
|
||||
|
||||
=head2 effective
|
||||
|
||||
A L<Zonemaster::Engine::Profile>.
|
||||
This is the effective profile.
|
||||
It serves as the global runtime configuration for Zonemaster Engine.
|
||||
Update it to change the configuration.
|
||||
|
||||
The effective profile is initialized with the default values declared
|
||||
in the L</PROFILE PROPERTIES> section.
|
||||
|
||||
All properties in the effective profile are always set (to valid values).
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
A constructor that returns a new profile with all properties unset.
|
||||
|
||||
my $profile = Zonemaster::Engine::Profile->new;
|
||||
|
||||
=head2 default
|
||||
|
||||
A constructor that returns a new profile with the default property
|
||||
values declared in the L</PROFILE PROPERTIES> section.
|
||||
|
||||
my $default = Zonemaster::Engine::Profile->default;
|
||||
|
||||
=head2 from_json
|
||||
|
||||
A constructor that returns a new profile with values parsed from a JSON string.
|
||||
|
||||
my $profile = Zonemaster::Engine::Profile->from_json( '{ "no_network": true }' );
|
||||
|
||||
The returned profile has set values for all properties specified in the
|
||||
given string.
|
||||
The remaining properties are unset.
|
||||
|
||||
Dies if the given string is illegal according to the L</JSON REPRESENTATION>
|
||||
section or if the property values are illegal according to the L</PROFILE
|
||||
PROPERTIES> section.
|
||||
|
||||
=head2 from_yaml
|
||||
|
||||
A constructor that returns a new profile with values parsed from a YAML string.
|
||||
|
||||
my $profile = Zonemaster::Engine::Profile->from_yaml( <<EOF
|
||||
no_network: true
|
||||
EOF
|
||||
);
|
||||
|
||||
The returned profile has set values for all properties specified in the
|
||||
given string.
|
||||
The remaining properties are unset.
|
||||
|
||||
Dies if the given string is illegal according to the L</YAML REPRESENTATION>
|
||||
section or if the property values are illegal according to the L</PROFILE
|
||||
PROPERTIES> section.
|
||||
|
||||
=head1 INSTANCE METHODS
|
||||
|
||||
=head2 get
|
||||
|
||||
Get the value of a property.
|
||||
|
||||
my $value = $profile1->get( 'net.ipv6' );
|
||||
|
||||
Returns value of the given property, or C<undef> if the property is unset.
|
||||
For boolean properties the returned value is either C<1> for true or C<0> for
|
||||
false.
|
||||
For properties with complex types, the returned value is a
|
||||
L<deep copy|https://en.wiktionary.org/wiki/deep_copy#Noun>.
|
||||
|
||||
Dies if the given property name is invalid.
|
||||
|
||||
=head2 set
|
||||
|
||||
Set the value of a property.
|
||||
|
||||
$profile1->set( 'net.ipv6', 0 );
|
||||
|
||||
Takes a property name and value and updates the property accordingly.
|
||||
For boolean properties any truthy value is interpreted as true and any falsy
|
||||
value except C<undef> is interpreted as false.
|
||||
|
||||
Dies if the given property name is invalid.
|
||||
|
||||
Dies if the value is C<undef> or otherwise invalid for the given property.
|
||||
|
||||
=head2 merge
|
||||
|
||||
Merge the profile data of another profile into this one.
|
||||
|
||||
$profile1->merge( $other );
|
||||
|
||||
Properties from the other profile take precedence when the same property
|
||||
name exists in both profiles.
|
||||
The other profile object remains unmodified.
|
||||
|
||||
=head2 to_json
|
||||
|
||||
Serialize the profile to the L</JSON REPRESENTATION> format.
|
||||
|
||||
my $string = $profile->to_json();
|
||||
|
||||
Returns a string.
|
||||
|
||||
=head2 to_yaml
|
||||
|
||||
Serialize the profile to the L</JSON REPRESENTATION> format.
|
||||
|
||||
my $string = $profile->to_yaml();
|
||||
|
||||
Returns a string.
|
||||
|
||||
=head2 all_properties
|
||||
|
||||
Get the names of all properties.
|
||||
|
||||
Returns a sorted list of strings.
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=head2 _get_profile_paths
|
||||
|
||||
Internal method used to get all the paths of a nested hashes-of-hashes.
|
||||
It creates a hash where keys are dotted keys of the nested hashes-of-hashes
|
||||
that exist in %profile_properties_details.
|
||||
|
||||
_get_profile_paths(\%paths, $internal);
|
||||
|
||||
=head2 _get_value_from_nested_hash
|
||||
|
||||
Internal method used to get a value in a nested hashes-of-hashes.
|
||||
|
||||
_get_value_from_nested_hash( $hash_ref, @path );
|
||||
|
||||
Where $hash_ref is the hash to explore and @path are the labels of the property to get.
|
||||
|
||||
@path = split /\./, q{resolver.defaults.usevc};
|
||||
|
||||
=head2 _set_value_to_nested_hash
|
||||
|
||||
Internal method used to set a value in a nested hashes-of-hashes.
|
||||
|
||||
_set_value_from_nested_hash( $hash_ref, $value, @path );
|
||||
|
||||
Where $hash_ref is the hash to explore and @path are the labels of the property to set.
|
||||
|
||||
@path = split /\./, q{resolver.defaults.usevc};
|
||||
|
||||
=head1 PROFILE PROPERTIES
|
||||
|
||||
Each property has a name and is either set or unset.
|
||||
If it is set it has a value that is valid for that specific property.
|
||||
Here is a listing of all the properties and their respective sets of
|
||||
valid values.
|
||||
|
||||
=head2 resolver.defaults.retrans
|
||||
|
||||
An integer between 1 and 255 inclusive. The number of seconds between retries.
|
||||
Default 3.
|
||||
|
||||
=head2 resolver.defaults.retry
|
||||
|
||||
An integer between 1 and 255 inclusive.
|
||||
The number of times a query is sent before we give up. Default 2.
|
||||
|
||||
=head2 resolver.defaults.fallback
|
||||
|
||||
A boolean. If true, UDP queries that get responses with the C<TC>
|
||||
flag set will be automatically resent over TCP or using EDNS. Default
|
||||
true.
|
||||
|
||||
In ldns-1.7.0 (NLnet Labs), in case of truncated answer when UDP is used,
|
||||
the same query is resent with EDNS0 and TCP (if needed). If you
|
||||
want the original answer (with TC bit set) and avoid this kind of
|
||||
replay, set this flag to false.
|
||||
|
||||
=head2 resolver.source4
|
||||
|
||||
A string representation of an IPv4 address or the empty string.
|
||||
The source address all resolver objects should use when sending queries over IPv4.
|
||||
|
||||
If set to "" (empty string), the OS default IPv4 address is used.
|
||||
|
||||
Default: "" (empty string).
|
||||
|
||||
=head2 resolver.source6
|
||||
|
||||
A string representation of an IPv6 address or the empty string.
|
||||
The source address all resolver objects should use when sending queries over IPv6.
|
||||
|
||||
If set to "" (empty string), the OS default IPv6 address is used.
|
||||
|
||||
Default: "" (empty string).
|
||||
|
||||
=head2 resolver.defaults.igntc
|
||||
|
||||
A boolean. Default false. Ignored. Deprecated and planned for removal in v2026.1. Remove it from your profile file.
|
||||
|
||||
=head2 resolver.defaults.recurse
|
||||
|
||||
A boolean. Default false. Ignored. Deprecated and planned for removal in v2026.1. Remove it from your profile file.
|
||||
|
||||
=head2 resolver.defaults.usevc
|
||||
|
||||
A boolean. Default false. Ignored. Deprecated and planned for removal in v2026.1. Remove it from your profile file.
|
||||
|
||||
=head2 net.ipv4
|
||||
|
||||
A boolean. If true, resolver objects are allowed to send queries over
|
||||
IPv4. Default true.
|
||||
|
||||
=head2 net.ipv6
|
||||
|
||||
A boolean. If true, resolver objects are allowed to send queries over
|
||||
IPv6. Default true.
|
||||
|
||||
=head2 no_network
|
||||
|
||||
A boolean. If true, network traffic is forbidden. Default false.
|
||||
|
||||
Use when you want to be sure that any data is only taken from a preloaded
|
||||
cache.
|
||||
|
||||
=head2 asn_db.style
|
||||
|
||||
A string that is either C<"Cymru"> or C<"RIPE"> (case-insensitive).
|
||||
|
||||
Defines which service will be used for AS lookup zones.
|
||||
|
||||
Default C<"Cymru">.
|
||||
|
||||
=head2 asn_db.sources
|
||||
|
||||
A hash of arrayrefs of strings. The currently supported keys are C<"Cymru"> or C<"RIPE"> (case-insensitive).
|
||||
|
||||
For C<"Cymru">, the strings are domain names. For C<"RIPE">, they are WHOIS servers. Normally only the first
|
||||
item in the list will be used, the rest are backups in case the previous ones didn't work.
|
||||
|
||||
Default C<{Cymru: [ "asnlookup.zonemaster.net", "asn.cymru.com" ], RIPE: [ "riswhois.ripe.net" ]}>.
|
||||
|
||||
=head2 cache
|
||||
|
||||
A hash of hashes. The currently supported key is C<"redis">.
|
||||
Default C<{}>.
|
||||
|
||||
=head3 redis
|
||||
|
||||
A hashref. The currently supported keys are C<"server"> and C<"expire">.
|
||||
|
||||
Specifies the address of the Redis server used to perform global caching
|
||||
(C<cache.redis.server>) and an optional expire time (C<cache.redis.expire>).
|
||||
|
||||
C<cache.redis.server> must be a string in the form C<host:port>.
|
||||
C<cache.redis.expire> must be a non-negative integer and defines a time in seconds.
|
||||
Default is 300 seconds.
|
||||
|
||||
=head2 logfilter
|
||||
|
||||
A complex data structure. Default C<{}>.
|
||||
|
||||
Specifies the severity level of each tag emitted by a specific module.
|
||||
The intended use is to remove known erroneous results.
|
||||
E.g. if you know that a certain name server is recursive and for some
|
||||
reason should be, you can use this functionality to lower the severity
|
||||
of the complaint about it to a lower level than normal.
|
||||
The C<test_levels> item also specifies tag severity level, but with
|
||||
coarser granularity and lower precedence.
|
||||
|
||||
The data under the C<logfilter> key should be structured like this:
|
||||
|
||||
Module
|
||||
Tag
|
||||
Array of exceptions
|
||||
"when"
|
||||
Hash with conditions
|
||||
"set"
|
||||
Severity level to set if all conditions match
|
||||
|
||||
The hash with conditions should have keys matching the attributes of
|
||||
the log entry that's being filtered (check the translation files to see
|
||||
what they are). The values for the keys should be either a single value
|
||||
that the attribute should be, or an array of values any one of which the
|
||||
attribute should be.
|
||||
|
||||
A complete logfilter structure might look like this:
|
||||
|
||||
{
|
||||
"A_MODULE": {
|
||||
"SOME_TAG": [
|
||||
{
|
||||
"when": {
|
||||
"count": 1,
|
||||
"type": [
|
||||
"this",
|
||||
"or"
|
||||
]
|
||||
},
|
||||
"set": "INFO"
|
||||
},
|
||||
{
|
||||
"when": {
|
||||
"count": 128,
|
||||
"type": [
|
||||
"that"
|
||||
]
|
||||
},
|
||||
"set": "INFO"
|
||||
}
|
||||
]
|
||||
},
|
||||
"ANOTHER_MODULE": {
|
||||
"OTHER_TAG": [
|
||||
{
|
||||
"when": {
|
||||
"bananas": 0
|
||||
},
|
||||
"set": "WARNING"
|
||||
}
|
||||
]
|
||||
}
|
||||
}
|
||||
|
||||
This would set the severity level to C<INFO> for any C<A_MODULE:SOME_TAG>
|
||||
messages that had a C<count> attribute set to 1 and a C<type> attribute
|
||||
set to either C<this> or C<or>.
|
||||
This also would set the level to C<INFO> for any C<A_MODULE:SOME_TAG>
|
||||
messages that had a C<count> attribute set to 128 and a C<type> attribute
|
||||
set to C<that>.
|
||||
And this would set the level to C<WARNING> for any C<ANOTHER_MODULE:OTHER_TAG>
|
||||
messages that had a C<bananas> attribute set to 0.
|
||||
|
||||
=head2 test_levels
|
||||
|
||||
A complex data structure.
|
||||
|
||||
Specifies the severity level of each tag emitted by a specific module.
|
||||
The C<logfilter> item also specifies tag severity level, but with finer
|
||||
granularity and higher precedence.
|
||||
|
||||
At the top level of this data structure are two levels of nested hashrefs.
|
||||
The keys of the top level hash are names of test implementation modules
|
||||
(without the C<Zonemaster::Engine::Test::> prefix).
|
||||
The keys of the second level hashes are tags that the respective
|
||||
modules emit.
|
||||
The values of the second level hashes are mapped to severity levels.
|
||||
|
||||
The various L<test case specifications|
|
||||
https://github.com/zonemaster/zonemaster/tree/master/docs/specifications/tests/README.md>
|
||||
define the default severity level for some of the messages.
|
||||
These specifications are the only authoritative documents on the default
|
||||
severity level for the various messages.
|
||||
For messages not defined in any of these specifications you can use the
|
||||
following command to query the default severity level directly from the actual
|
||||
default profile.
|
||||
|
||||
```sh
|
||||
perl -MZonemaster::Engine::Test -E 'say Zonemaster::Engine::Profile->default->to_json' | jq -S .test_levels
|
||||
```
|
||||
|
||||
For messages neither defined in test specifications, nor listed in the default
|
||||
profile, the default severity level is C<DEBUG>.
|
||||
|
||||
I<Note:> Sometimes multiple test cases within the same test module define
|
||||
messages for the same tag.
|
||||
When they do, it is imperative that all test cases define the same severity
|
||||
level for the tag.
|
||||
|
||||
=head2 test_cases
|
||||
|
||||
An arrayref of names of implemented test cases (in all lower-case) as listed in the
|
||||
L<test case specifications|https://github.com/zonemaster/zonemaster/tree/master/docs/specifications/tests/ImplementedTestCases.md>.
|
||||
Default is an arrayref listing all the test cases.
|
||||
|
||||
Specifies which test cases can be run by the testing suite.
|
||||
|
||||
=head2 test_cases_vars.dnssec04.REMAINING_SHORT
|
||||
|
||||
A positive integer value.
|
||||
Recommended lower bound for signatures' remaining validity time (in seconds) in
|
||||
test case L<DNSSEC04|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/DNSSEC-TP/dnssec04.md>.
|
||||
Related to the REMAINING_SHORT message tag from this test case.
|
||||
Default C<43200> (12 hours in seconds).
|
||||
|
||||
=head2 test_cases_vars.dnssec04.REMAINING_LONG
|
||||
|
||||
A positive integer value.
|
||||
Recommended upper bound for signatures' remaining validity time (in seconds) in
|
||||
test case L<DNSSEC04|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/DNSSEC-TP/dnssec04.md>.
|
||||
Related to the REMAINING_LONG message tag from this test case.
|
||||
Default C<15552000> (180 days in seconds).
|
||||
|
||||
=head2 test_cases_vars.dnssec04.DURATION_LONG
|
||||
|
||||
A positive integer value.
|
||||
Recommended upper bound for signatures' lifetime (in seconds) in the test case
|
||||
L<DNSSEC04|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/DNSSEC-TP/dnssec04.md>.
|
||||
Related to the DURATION_LONG message tag from this test case.
|
||||
Default C<15552000> (180 days in seconds).
|
||||
|
||||
=head2 test_cases_vars.zone02.SOA_REFRESH_MINIMUM_VALUE
|
||||
|
||||
A positive integer value.
|
||||
Recommended lower bound for SOA refresh values (in seconds) in test case
|
||||
L<ZONE02|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/Zone-TP/zone02.md>.
|
||||
Related to the REFRESH_MINIMUM_VALUE_LOWER message tag from this test case.
|
||||
Default C<14400> (4 hours in seconds).
|
||||
|
||||
=head2 test_cases_vars.zone04.SOA_RETRY_MINIMUM_VALUE
|
||||
|
||||
A positive integer value.
|
||||
Recommended lower bound for SOA retry values (in seconds) in test case
|
||||
L<ZONE04|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/Zone-TP/zone04.md>.
|
||||
Related to the RETRY_MINIMUM_VALUE_LOWER message tag from this test case.
|
||||
Default C<3600> (1 hour in seconds).
|
||||
|
||||
=head2 test_cases_vars.zone05.SOA_EXPIRE_MINIMUM_VALUE
|
||||
|
||||
A positive integer value.
|
||||
Recommended lower bound for SOA expire values (in seconds) in test case
|
||||
L<ZONE05|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/Zone-TP/zone05.md>.
|
||||
Related to the EXPIRE_MINIMUM_VALUE_LOWER message tag from this test case.
|
||||
Default C<604800> (1 week in seconds).
|
||||
|
||||
=head2 test_cases_vars.zone06.SOA_DEFAULT_TTL_MINIMUM_VALUE
|
||||
|
||||
A positive integer value.
|
||||
Recommended lower bound for SOA minimum values (in seconds) in test case
|
||||
L<ZONE06|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/Zone-TP/zone06.md>.
|
||||
Related to the SOA_DEFAULT_TTL_MAXIMUM_VALUE_LOWER message tag from this test case.
|
||||
Default C<300> (5 minutes in seconds).
|
||||
|
||||
=head2 test_cases_vars.zone06.SOA_DEFAULT_TTL_MAXIMUM_VALUE
|
||||
|
||||
A positive integer value.
|
||||
Recommended upper bound for SOA minimum values (in seconds) in test case
|
||||
L<ZONE06|
|
||||
https://github.com/zonemaster/zonemaster/blob/master/docs/specifications/tests/Zone-TP/zone06.md>.
|
||||
Related to the SOA_DEFAULT_TTL_MAXIMUM_VALUE_HIGHER message tag from this test case.
|
||||
Default C<86400> (1 day in seconds).
|
||||
|
||||
=head1 REPRESENTATIONS
|
||||
|
||||
=head2 JSON REPRESENTATION
|
||||
|
||||
Property names in L</PROFILE PROPERTIES> section correspond to paths in
|
||||
a datastructure of nested JSON objects.
|
||||
Property values are stored at their respective paths.
|
||||
Paths are formed from property names by splitting them at dot characters
|
||||
(U+002E).
|
||||
The left-most path component corresponds to a key in the top-most
|
||||
JSON object.
|
||||
Properties with unset values are omitted in the JSON representation.
|
||||
|
||||
For a complete example, refer to the file located by L<dist_file(
|
||||
"Zonemaster-Engine", "default.profile" )|File::ShareDir/dist_file>.
|
||||
A profile with the only two properties set, C<net.ipv4> = true and
|
||||
C<net.ipv6> = true has this JSON representation:
|
||||
|
||||
{
|
||||
"net": {
|
||||
"ipv4": true,
|
||||
"ipv6": true
|
||||
}
|
||||
}
|
||||
|
||||
=head2 YAML REPRESENTATION
|
||||
|
||||
Similar to the L</JSON REPRESENTATION> but uses a YAML format.
|
||||
|
||||
=cut
|
||||
665
zonemaster-engine/lib/Zonemaster/Engine/Recursor.pm
Normal file
665
zonemaster-engine/lib/Zonemaster/Engine/Recursor.pm
Normal file
@@ -0,0 +1,665 @@
|
||||
package Zonemaster::Engine::Recursor;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.1.0");
|
||||
|
||||
use Carp;
|
||||
use Class::Accessor "antlers";
|
||||
use File::ShareDir qw[dist_file];
|
||||
use File::Slurp qw( read_file );
|
||||
use JSON::PP;
|
||||
use Net::IP::XS;
|
||||
use List::MoreUtils qw[uniq];
|
||||
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::Engine::DNSName;
|
||||
use Zonemaster::Engine::Util qw( name ns parse_hints );
|
||||
use Zonemaster::Engine::Constants ":cname";
|
||||
|
||||
our %recurse_cache;
|
||||
our %_fake_addresses_cache;
|
||||
|
||||
sub init_recursor {
|
||||
my $hints_path = dist_file( 'Zonemaster-Engine', 'named.root' );
|
||||
my $hints_text = read_file( $hints_path );
|
||||
my $hints_data = parse_hints( $hints_text );
|
||||
Zonemaster::Engine::Recursor->add_fake_addresses( '.', $hints_data );
|
||||
}
|
||||
|
||||
sub add_fake_addresses {
|
||||
my ( $class, $domain, $href ) = @_;
|
||||
$domain = lc $domain;
|
||||
|
||||
foreach my $name ( keys %{$href} ) {
|
||||
my @ips = uniq @{ $href->{$name} };
|
||||
$name = lc $name;
|
||||
|
||||
push @{ $_fake_addresses_cache{$domain}{$name} }, ();
|
||||
foreach my $ip ( @ips ) {
|
||||
push @{ $_fake_addresses_cache{$domain}{$name} }, $ip;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub has_fake_addresses {
|
||||
my ( $class, $domain ) = @_;
|
||||
$domain = lc $domain;
|
||||
|
||||
return !!$_fake_addresses_cache{$domain};
|
||||
}
|
||||
|
||||
sub get_fake_addresses {
|
||||
my ( $class, $domain, $nsname ) = @_;
|
||||
( defined $domain ) or croak 'Argument must be defined: $domain';
|
||||
|
||||
$domain = lc $domain;
|
||||
$nsname = ( defined $nsname ) ? lc $nsname : q{};
|
||||
|
||||
if ( exists $_fake_addresses_cache{$domain}{$nsname} ) {
|
||||
return @{ $_fake_addresses_cache{$domain}{$nsname} };
|
||||
}
|
||||
else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
|
||||
sub get_fake_names {
|
||||
my ( $class, $domain ) = @_;
|
||||
$domain = lc $domain;
|
||||
|
||||
if ( exists $_fake_addresses_cache{$domain} ) {
|
||||
return keys %{$_fake_addresses_cache{$domain}};
|
||||
}
|
||||
else {
|
||||
return ();
|
||||
}
|
||||
}
|
||||
|
||||
sub remove_fake_addresses {
|
||||
my ( $class, $domain ) = @_;
|
||||
$domain = lc $domain;
|
||||
|
||||
delete $_fake_addresses_cache{$domain};
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub recurse {
|
||||
my ( $class, $name, $type, $dns_class, $ns ) = @_;
|
||||
$name = name( $name );
|
||||
$type //= 'A';
|
||||
$dns_class //= 'IN';
|
||||
|
||||
Zonemaster::Engine->logger->add( RECURSE => { name => $name, type => $type, class => $dns_class } );
|
||||
if ( exists $recurse_cache{$name}{$type}{$dns_class} ) {
|
||||
return $recurse_cache{$name}{$type}{$dns_class};
|
||||
}
|
||||
|
||||
my %state = ( ns => [ root_servers() ], count => 0, common => 0, seen => {}, glue => {} );
|
||||
if ( defined $ns ) {
|
||||
ref( $ns ) eq 'ARRAY' or croak 'Argument $ns must be an arrayref';
|
||||
$state{ns} = $ns;
|
||||
}
|
||||
|
||||
my ( $p, $state ) = $class->_recurse( $name, $type, $dns_class, \%state );
|
||||
$recurse_cache{$name}{$type}{$dns_class} = $p;
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
sub parent {
|
||||
my ( $class, $name ) = @_;
|
||||
$name = name( $name );
|
||||
|
||||
my ( $p, $state ) =
|
||||
$class->_recurse( $name, 'SOA', 'IN',
|
||||
{ ns => [ root_servers() ], count => 0, common => 0, seen => {}, glue => {} } );
|
||||
|
||||
my $pname;
|
||||
if ( name( $state->{trace}[0][0] ) eq name( $name ) ) {
|
||||
$pname = name( $state->{trace}[1][0] );
|
||||
}
|
||||
else {
|
||||
$pname = name( $state->{trace}[0][0] );
|
||||
}
|
||||
|
||||
# Extra check that parent really is parent.
|
||||
if ( $name->next_higher ne $pname ) {
|
||||
my $source_ns = $state->{trace}[0][1];
|
||||
my $source_ip = $state->{trace}[0][2];
|
||||
|
||||
# No $source_ns means we're looking at root taken from priming
|
||||
if ( $source_ns ) {
|
||||
my $pp;
|
||||
if ( $source_ns->can( 'query' ) ) {
|
||||
$pp = $source_ns->query( $name->next_higher->string, 'SOA' );
|
||||
}
|
||||
else {
|
||||
my $n = ns( $source_ns, $source_ip );
|
||||
$pp = $n->query( $name->next_higher->string, 'SOA' );
|
||||
}
|
||||
if ( $pp ) {
|
||||
my ( $rr ) = $pp->get_records( 'SOA', 'answer' );
|
||||
if ( $rr ) {
|
||||
$pname = name( $rr->owner );
|
||||
}
|
||||
}
|
||||
}
|
||||
} ## end if ( $name->next_higher...)
|
||||
|
||||
if ( wantarray() ) {
|
||||
return ( $pname, $p );
|
||||
}
|
||||
else {
|
||||
return $pname;
|
||||
}
|
||||
} ## end sub parent
|
||||
|
||||
sub _resolve_cname {
|
||||
my ( $class, $name, $type, $dns_class, $p, $state ) = @_;
|
||||
$name = name( $name );
|
||||
Zonemaster::Engine->logger->add( CNAME_START => { name => $name, type => $type, dns_class => $dns_class } );
|
||||
|
||||
my @cname_rrs = $p->get_records( 'CNAME', 'answer' );
|
||||
|
||||
# Remove duplicate CNAME RRs
|
||||
my ( %duplicate_cname_rrs, @original_rrs );
|
||||
for my $rr ( @cname_rrs ) {
|
||||
my $rr_hash = $rr->class . '/CNAME/' . lc($rr->owner) . '/' . lc($rr->cname);
|
||||
|
||||
if ( exists $duplicate_cname_rrs{$rr_hash} ) {
|
||||
$duplicate_cname_rrs{$rr_hash}++;
|
||||
}
|
||||
else {
|
||||
$duplicate_cname_rrs{$rr_hash} = 0;
|
||||
push @original_rrs, $rr;
|
||||
}
|
||||
}
|
||||
|
||||
unless ( scalar @original_rrs == scalar @cname_rrs ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_RECORDS_DUPLICATES => {
|
||||
records => join(';', map { "$_ => $duplicate_cname_rrs{$_}" if $duplicate_cname_rrs{$_} > 0 } keys %duplicate_cname_rrs )
|
||||
}
|
||||
);
|
||||
@cname_rrs = @original_rrs;
|
||||
}
|
||||
|
||||
# Break if there are too many records
|
||||
if ( scalar @cname_rrs > $CNAME_MAX_RECORDS ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_RECORDS_TOO_MANY => { name => $name, count => scalar @cname_rrs, max => $CNAME_MAX_RECORDS } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
my ( %cnames, %seen_targets, %forbidden_targets );
|
||||
for my $rr ( @cname_rrs ) {
|
||||
my $rr_owner = name( $rr->owner );
|
||||
my $rr_target = name( $rr->cname );
|
||||
|
||||
# Multiple CNAME records with same owner name
|
||||
if ( exists $forbidden_targets{lc( $rr_owner )} ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_RECORDS_MULTIPLE_FOR_NAME => { name => $rr_owner } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
# CNAME owner name is target, or target has already been seen in this response, or owner name cannot be a target
|
||||
if ( lc( $rr_owner ) eq lc( $rr_target ) or exists $seen_targets{lc( $rr_target )} or grep { $_ eq lc( $rr_target ) } ( keys %forbidden_targets ) ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_LOOP_INNER => { name => join( ';', map { $_->owner } @cname_rrs ), target => join( ';', map { $_->cname } @cname_rrs ) } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
$seen_targets{lc( $rr_target )} = 1;
|
||||
$forbidden_targets{lc( $rr_owner )} = 1;
|
||||
$cnames{$rr_owner} = $rr_target;
|
||||
}
|
||||
|
||||
# Get final CNAME target
|
||||
my $target = $name;
|
||||
my $cname_counter = 0;
|
||||
while ( $cnames{$target} ) {
|
||||
return ( undef, $state ) if $cname_counter > $CNAME_MAX_RECORDS; # Loop protection (for good measure only - data in %cnames is sanitized already)
|
||||
$target = $cnames{$target};
|
||||
$cname_counter++;
|
||||
}
|
||||
|
||||
# Make sure that the CNAME chain from the RRs is not broken
|
||||
if ( $cname_counter != scalar @cname_rrs ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_RECORDS_CHAIN_BROKEN => { name => $name, cname_rrs => scalar @cname_rrs, cname_counter => $cname_counter } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
# Check if there are RRs of queried type (QTYPE) in the answer section of the response;
|
||||
if ( scalar $p->get_records( $type, 'answer' ) ) {
|
||||
# RR of type QTYPE for CNAME target is already in the response; no need to recurse
|
||||
if ( $p->has_rrs_of_type_for_name( $type, $target ) ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_FOLLOWED_IN_ZONE => { name => $name, type => $type, target => $target } );
|
||||
return ( $p, $state );
|
||||
}
|
||||
|
||||
# There is a record of type QTYPE but with different owner name than CNAME target; no need to recurse
|
||||
Zonemaster::Engine->logger->add( CNAME_NO_MATCH => { name => $name, type => $type, target => $target, owner_names => join( ';', map { $_->owner } $p->get_records( $type ) ) } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
# CNAME target has already been followed (outer loop); no need to recurse
|
||||
if ( exists $state->{in_progress}{lc( $target )}{$type} ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_LOOP_OUTER => { name => $name, target => $target, targets_seen => join( ';', keys %{ $state->{tseen} } ) } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
# Safe-guard against anormaly long consecutive CNAME chains; no need to recurse
|
||||
$state->{tseen}{lc( $target )} = 1;
|
||||
$state->{tcount} += 1;
|
||||
|
||||
if ( $state->{tcount} > $CNAME_MAX_CHAIN_LENGTH ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_CHAIN_TOO_LONG => { count => $state->{tcount}, max => $CNAME_MAX_CHAIN_LENGTH } );
|
||||
return ( undef, $state );
|
||||
}
|
||||
|
||||
# Make sure that the CNAME target is out of zone before making a new recursive lookup for CNAME target
|
||||
unless ( $name->is_in_bailiwick( $target ) ) {
|
||||
Zonemaster::Engine->logger->add( CNAME_FOLLOWED_OUT_OF_ZONE => { name => $name, target => $target } );
|
||||
( $p, $state ) = $class->_recurse( $target, $type, $dns_class,
|
||||
{ ns => [ root_servers() ], count => 0, common => 0, seen => {}, tseen => $state->{tseen}, tcount => $state->{tcount}, glue => {}, in_progress => $state->{in_progress} });
|
||||
}
|
||||
else {
|
||||
# What do do here?
|
||||
}
|
||||
|
||||
return ( $p, $state );
|
||||
}
|
||||
|
||||
sub _recurse {
|
||||
my ( $class, $name, $type, $dns_class, $state ) = @_;
|
||||
$name = q{} . name( $name );
|
||||
$state->{qname} //= $name;
|
||||
|
||||
if ( $state->{in_progress}{$name}{$type} ) {
|
||||
return;
|
||||
}
|
||||
$state->{in_progress}{$name}{$type} = 1;
|
||||
|
||||
while ( my $ns = pop @{ $state->{ns} } ) {
|
||||
my $nsname = $ns->can( 'name' ) ? q{} . $ns->name : q{};
|
||||
my $nsaddress = $ns->can( 'address' ) ? $ns->address->ip : q{};
|
||||
Zonemaster::Engine->logger->add(
|
||||
RECURSE_QUERY => {
|
||||
source => "$ns",
|
||||
ns => $nsname,
|
||||
address => $nsaddress,
|
||||
name => $name,
|
||||
type => $type,
|
||||
class => $dns_class,
|
||||
}
|
||||
);
|
||||
my $p = $class->_do_query( $ns, $name, $type, { class => $dns_class }, $state );
|
||||
|
||||
next if not $p; # Ask next server if no response
|
||||
|
||||
if ( $p->rcode eq 'REFUSED' or $p->rcode eq 'SERVFAIL' ) {
|
||||
# Respond with these if we can't get a better response
|
||||
$state->{candidate} = $p;
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $p->no_such_record ) { # Node exists, but not record
|
||||
return ( $p, $state );
|
||||
}
|
||||
|
||||
if ( $p->no_such_name ) { # Node does not exist
|
||||
return ( $p, $state );
|
||||
}
|
||||
|
||||
if ( $class->_is_answer( $p ) ) { # Return answer, or resolve CNAME
|
||||
if ( not $p->has_rrs_of_type_for_name( $type, $name ) and scalar $p->get_records_for_name( 'CNAME', $name, 'answer' ) ) {
|
||||
( $p, $state ) = $class->_resolve_cname( $name, $type, $dns_class, $p, $state );
|
||||
}
|
||||
|
||||
return ( $p, $state );
|
||||
}
|
||||
|
||||
# So it's not an error, not an empty response and not an answer
|
||||
|
||||
if ( $p->is_redirect ) {
|
||||
my $zname = name( lc( ( $p->get_records( 'ns' ) )[0]->name ) );
|
||||
|
||||
next if $zname eq '.'; # Redirect to root is never right.
|
||||
|
||||
next if $state->{seen}{$zname}; # We followed this redirect before
|
||||
|
||||
$state->{seen}{$zname} = 1;
|
||||
my $common = name( $zname )->common( name( $state->{qname} ) );
|
||||
|
||||
next if $common < $state->{common}; # Redirect going up the hierarchy is not OK
|
||||
|
||||
$state->{common} = $common;
|
||||
$state->{ns} = $class->get_ns_from( $p, $state ); # Follow redirect
|
||||
$state->{count} += 1;
|
||||
if ( $state->{count} > 20 ) { # Loop protection
|
||||
Zonemaster::Engine->logger->add( LOOP_PROTECTION => {
|
||||
caller => 'Zonemaster::Engine::Recursor->_recurse',
|
||||
child_zone_name => $name,
|
||||
name => $zname
|
||||
}
|
||||
);
|
||||
|
||||
return ( undef, $state );
|
||||
}
|
||||
unshift @{ $state->{trace} }, [ $zname, $ns, $p->answerfrom ];
|
||||
|
||||
next;
|
||||
} ## end if ( $p->is_redirect )
|
||||
} ## end while ( my $ns = pop @{ $state...})
|
||||
return ( $state->{candidate}, $state ) if $state->{candidate};
|
||||
|
||||
return ( undef, $state );
|
||||
} ## end sub _recurse
|
||||
|
||||
sub _do_query {
|
||||
my ( $class, $ns, $name, $type, $opts, $state ) = @_;
|
||||
|
||||
if ( ref( $ns ) and $ns->can( 'query' ) ) {
|
||||
my $p = $ns->query( $name, $type, $opts );
|
||||
|
||||
if ( $p ) {
|
||||
for my $rr ( grep { $_->type eq 'A' or $_->type eq 'AAAA' } $p->answer, $p->additional ) {
|
||||
$state->{glue}{ lc( Zonemaster::Engine::DNSName->from_string( $rr->name ) ) }{ $rr->address } = 1;
|
||||
}
|
||||
}
|
||||
return $p;
|
||||
}
|
||||
elsif ( my $href = $state->{glue}{ lc( name( $ns ) ) } ) {
|
||||
foreach my $addr ( keys %$href ) {
|
||||
my $realns = ns( $ns, $addr );
|
||||
my $p = $class->_do_query( $realns, $name, $type, $opts, $state );
|
||||
if ( $p ) {
|
||||
return $p;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
else {
|
||||
$state->{glue}{ lc( name( $ns ) ) } = {};
|
||||
my @addr = $class->get_addresses_for( $ns, $state );
|
||||
if ( @addr > 0 ) {
|
||||
foreach my $addr ( @addr ) {
|
||||
$state->{glue}{ lc( name( $ns ) ) }{ $addr->short } = 1;
|
||||
my $new = ns( $ns, $addr->short );
|
||||
my $p = $new->query( $name, $type, $opts );
|
||||
return $p if $p;
|
||||
}
|
||||
return;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
} ## end sub _do_query
|
||||
|
||||
sub get_ns_from {
|
||||
my ( $class, $p, $state ) = @_;
|
||||
my ( @new, @extra );
|
||||
|
||||
my @names = sort map { Zonemaster::Engine::DNSName->from_string( lc( $_->nsdname ) ) } $p->get_records( 'ns' );
|
||||
|
||||
$state->{glue}{ lc( Zonemaster::Engine::DNSName->from_string( $_->name ) ) }{ $_->address } = 1
|
||||
for ( $p->get_records( 'a' ), $p->get_records( 'aaaa' ) );
|
||||
|
||||
foreach my $name ( @names ) {
|
||||
if ( exists $state->{glue}{ lc( $name ) } ) {
|
||||
for my $addr ( keys %{ $state->{glue}{ lc( $name ) } } ) {
|
||||
push @new, ns( $name, $addr );
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @extra, $name;
|
||||
}
|
||||
}
|
||||
|
||||
@new = sort { $a->name cmp $b->name or $a->address->ip cmp $b->address->ip } @new;
|
||||
@extra = sort { $a cmp $b } @extra;
|
||||
|
||||
return [ @new, @extra ];
|
||||
} ## end sub get_ns_from
|
||||
|
||||
sub get_addresses_for {
|
||||
my ( $class, $name, $state ) = @_;
|
||||
my @res;
|
||||
$state //=
|
||||
{ ns => [ root_servers() ], count => 0, common => 0, seen => {} };
|
||||
|
||||
my ( $pa ) = $class->_recurse(
|
||||
"$name", 'A', 'IN',
|
||||
{
|
||||
ns => [ root_servers() ],
|
||||
count => $state->{count},
|
||||
common => 0,
|
||||
in_progress => $state->{in_progress},
|
||||
glue => $state->{glue}
|
||||
}
|
||||
);
|
||||
|
||||
# Name does not exist, just stop
|
||||
if ( $pa and $pa->no_such_name ) {
|
||||
return;
|
||||
}
|
||||
|
||||
my ( $paaaa ) = $class->_recurse(
|
||||
"$name", 'AAAA', 'IN',
|
||||
{
|
||||
ns => [ root_servers() ],
|
||||
count => $state->{count},
|
||||
common => 0,
|
||||
in_progress => $state->{in_progress},
|
||||
glue => $state->{glue}
|
||||
}
|
||||
);
|
||||
|
||||
my @rrs;
|
||||
my %cname;
|
||||
if ( $pa ) {
|
||||
push @rrs, $pa->get_records( 'a' );
|
||||
$cname{ $_->cname } = 1 for $pa->get_records_for_name( 'CNAME', $name );
|
||||
}
|
||||
if ( $paaaa ) {
|
||||
push @rrs, $paaaa->get_records( 'aaaa' );
|
||||
$cname{ $_->cname } = 1 for $paaaa->get_records_for_name( 'CNAME', $name );
|
||||
}
|
||||
|
||||
foreach my $rr ( sort { $a->address cmp $b->address } @rrs ) {
|
||||
if ( name( $rr->name ) eq $name or $cname{ $rr->name } ) {
|
||||
push @res, Net::IP::XS->new( $rr->address );
|
||||
}
|
||||
}
|
||||
return @res;
|
||||
} ## end sub get_addresses_for
|
||||
|
||||
sub _is_answer {
|
||||
my ( $class, $packet ) = @_;
|
||||
|
||||
return ( $packet->type eq 'answer' );
|
||||
}
|
||||
|
||||
sub clear_cache {
|
||||
%recurse_cache = ();
|
||||
return;
|
||||
}
|
||||
|
||||
sub root_servers {
|
||||
my $root_addresses = $_fake_addresses_cache{'.'};
|
||||
|
||||
my @servers;
|
||||
for my $name ( sort keys %{ $root_addresses } ) {
|
||||
for my $address ( @{ $root_addresses->{$name} } ) {
|
||||
push @servers, ns( $name, $address );
|
||||
}
|
||||
}
|
||||
|
||||
return @servers;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Recursor - recursive resolver for Zonemaster
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $packet = Zonemaster::Engine::Recursor->recurse( $name, $type, $dns_class );
|
||||
my $pname = Zonemaster::Engine::Recursor->parent( 'example.org' );
|
||||
|
||||
=head1 CLASS VARIABLES
|
||||
|
||||
=head2 %recurse_cache
|
||||
|
||||
Will cache result of previous queries.
|
||||
|
||||
=head2 %_fake_addresses_cache
|
||||
|
||||
A hash of hashrefs of arrayrefs.
|
||||
The keys of the top level hash are domain names.
|
||||
The keys of the second level hashes are name server names (normalized to lower
|
||||
case).
|
||||
The elements of the third level arrayrefs are IP addresses.
|
||||
|
||||
The IP addresses are those of the nameservers which are used in case of fake
|
||||
delegations (pre-publication tests).
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 init_recursor()
|
||||
|
||||
Initialize the recursor by loading the root hints.
|
||||
|
||||
=head2 recurse($name[, $type, $class, $ns])
|
||||
|
||||
Does a recursive resolution for the given name down from the root servers (or for the given name server(s), if any).
|
||||
Only the first argument is mandatory. The rest are optional and default to, respectively: 'A', 'IN', and L</root_servers()>.
|
||||
|
||||
Takes a string or a L<Zonemaster::Engine::DNSName> object (name); and optionally a string (query type), a string (query class),
|
||||
and an arrayref of L<Zonemaster::Engine::Nameserver> objects.
|
||||
|
||||
Returns a L<Zonemaster::Engine::Packet> object (which can be C<undef>).
|
||||
|
||||
=head2 parent($name)
|
||||
|
||||
Does a recursive resolution from the root down for the given name (using type C<SOA> and class C<IN>). If the resolution is successful, it returns
|
||||
the domain name of the second-to-last step. If the resolution is unsuccessful, it returns the domain name of the last step.
|
||||
|
||||
=head2 get_ns_from($packet, $state)
|
||||
|
||||
Internal method. Takes a packet and a recursion state and returns a list of ns objects. Used to follow redirections.
|
||||
|
||||
=head2 get_addresses_for($name[, $state])
|
||||
|
||||
Takes a name and returns a (possibly empty) list of IP addresses for
|
||||
that name (in the form of L<Net::IP::XS> objects). When used
|
||||
internally by the recursor it's passed a recursion state as its second
|
||||
argument.
|
||||
|
||||
=head2 add_fake_addresses($domain, $data)
|
||||
|
||||
Class method to create fake addresses for fake delegations for a specified domain from data provided.
|
||||
|
||||
=head2 has_fake_addresses($domain)
|
||||
|
||||
Check if there is at least one fake nameserver specified for the given domain.
|
||||
|
||||
=head2 get_fake_addresses($domain, $nsname)
|
||||
|
||||
Returns a list of all cached fake addresses for the given domain and name server name.
|
||||
Returns an empty list if no data is cached for the given arguments.
|
||||
|
||||
=head2 get_fake_names($domain)
|
||||
|
||||
Returns a list of all cached fake name server names for the given domain.
|
||||
Returns an empty list if no data is cached for the given argument.
|
||||
|
||||
=head2 remove_fake_addresses($domain)
|
||||
|
||||
Remove fake delegation data for a specified domain.
|
||||
|
||||
=head2 clear_cache()
|
||||
|
||||
Class method to empty the cache of responses to recursive queries (but not the ones for fake delegations).
|
||||
|
||||
N.B. This method does not affect fake delegation data.
|
||||
|
||||
=head2 root_servers()
|
||||
|
||||
Returns a list of ns objects representing the root servers.
|
||||
|
||||
my @name_servers = Zonemaster::Engine::Recursor->root_servers();
|
||||
|
||||
The default list of root servers is read from a file installed in the shared data directory.
|
||||
This list can be replaced like so:
|
||||
|
||||
Zonemaster::Engine::Recursor->remove_fake_addresses( '.' );
|
||||
Zonemaster::Engine::Recursor->add_fake_addresses(
|
||||
'.',
|
||||
{
|
||||
'ns1.example' => ['192.0.2.1'],
|
||||
'ns2.example' => ['192.0.2.2'],
|
||||
}
|
||||
);
|
||||
|
||||
=head1 INTERNAL METHODS
|
||||
|
||||
=head2 _recurse()
|
||||
|
||||
my ( $p, $state_hash ) = _recurse( $name, $type_string, $dns_class_string, $p, $state_hash );
|
||||
|
||||
Performs a recursive lookup resolution for the given arguments. Used by the L<recursive lookup|/recurse($name, $type, $class)> method in this module.
|
||||
|
||||
Takes a L<Zonemaster::Engine::DNSName> object, a string (query type), a string (DNS class), a L<Zonemaster::Engine::Packet> object, and a reference to a hash.
|
||||
The mandatory keys for that hash are 'ns' (arrayref), 'count' (integer), 'common' (integer), 'seen' (hash), 'glue' (hash) and optional keys are 'in_progress'
|
||||
(hash), 'candidate' (L<Zonemaster::Engine::Packet> object or C<undef>), 'trace' (array), 'tseen' (hash), 'tcount' (integer).
|
||||
|
||||
Returns a L<Zonemaster::Engine::Packet> (or C<undef>) and a hash.
|
||||
|
||||
=head2 _resolve_cname()
|
||||
|
||||
my ( $p, $state_hash ) = _resolve_cname( $name, $type_string, $dns_class_string, $p, $state_hash );
|
||||
|
||||
Performs CNAME resolution for the given arguments. Used by the L<recursive lookup|/_recurse()> helper method in this module.
|
||||
If CNAMEs are successfully resolved, a L<packet|Zonemaster::Engine::Packet> (which could be C<undef>) is returned and
|
||||
one of the following message tags is logged:
|
||||
|
||||
=over
|
||||
|
||||
=item CNAME_FOLLOWED_IN_ZONE
|
||||
|
||||
=item CNAME_FOLLOWED_OUT_OF_ZONE
|
||||
|
||||
=back
|
||||
|
||||
Note that CNAME records are also validated and, in case of an error, an empty (C<undef>) L<packet|Zonemaster::Engine::Packet>
|
||||
is returned and one of the following message tags will be logged:
|
||||
|
||||
=over
|
||||
|
||||
=item CNAME_CHAIN_TOO_LONG
|
||||
|
||||
=item CNAME_LOOP_INNER
|
||||
|
||||
=item CNAME_LOOP_OUTER
|
||||
|
||||
=item CNAME_NO_MATCH
|
||||
|
||||
=item CNAME_RECORDS_CHAIN_BROKEN
|
||||
|
||||
=item CNAME_RECORDS_MULTIPLE_FOR_NAME
|
||||
|
||||
=item CNAME_RECORDS_TOO_MANY
|
||||
|
||||
=back
|
||||
|
||||
Takes a L<Zonemaster::Engine::DNSName> object, a string (query type), a string (DNS class), a L<Zonemaster::Engine::Packet>, and a reference to a hash.
|
||||
|
||||
Returns a L<Zonemaster::Engine::Packet> (or C<undef>) and a reference to a hash.
|
||||
|
||||
=cut
|
||||
350
zonemaster-engine/lib/Zonemaster/Engine/Test.pm
Normal file
350
zonemaster-engine/lib/Zonemaster/Engine/Test.pm
Normal file
@@ -0,0 +1,350 @@
|
||||
package Zonemaster::Engine::Test;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare( "v1.1.12" );
|
||||
|
||||
use Readonly;
|
||||
use Module::Find;
|
||||
use Net::IP::XS;
|
||||
use List::MoreUtils;
|
||||
use Clone;
|
||||
|
||||
use Zonemaster::LDNS;
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::Engine::Profile;
|
||||
use Zonemaster::Engine::Util;
|
||||
|
||||
use IO::Socket::INET6; # Lazy-loads, so make sure it's here for the version logging
|
||||
|
||||
use File::ShareDir qw[dist_file];
|
||||
use File::Slurp qw[read_file];
|
||||
use Scalar::Util qw[blessed];
|
||||
use POSIX qw[strftime];
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Test - Module implementing methods to find, load and execute all Test modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @results = Zonemaster::Engine::Test->run_all_for($zone);
|
||||
my @results = Zonemaster::Engine::Test->run_module('DNSSEC', $zone);
|
||||
my @results = Zonemaster::Engine::Test->run_one('DNSSEC', 'dnssec01', $zone);
|
||||
|
||||
=head1 TEST MODULES
|
||||
|
||||
Test modules are defined as modules with names starting with C<Zonemaster::Engine::Test::>.
|
||||
They are expected to provide at least the following class methods:
|
||||
|
||||
=over
|
||||
|
||||
=item all()
|
||||
|
||||
This will be given a L<Zonemaster::Engine::Zone> object as its only argument, and, after running the
|
||||
Test Cases for that Test module, is expected to return a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
This is the entry point used by the L</run_all_for()> and L</run_module()> methods of this class.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
=over
|
||||
|
||||
=item version()
|
||||
|
||||
This must return the version of the Test module.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
=over
|
||||
|
||||
=item metadata()
|
||||
|
||||
This must return a reference to a hash, the keys of which are the names of all Test Cases in
|
||||
the module, and the corresponding values are references to an array containing all the message
|
||||
tags that the Test Case can use in L<log entries|Zonemaster::Engine::Logger::Entry>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
=over
|
||||
|
||||
=item tag_descriptions()
|
||||
|
||||
This must return a reference to a hash, the keys of which are the message tags and the corresponding values
|
||||
are strings (message IDs) corresponding to user-friendly English translations of those message tags.
|
||||
Keep in mind that the message ids will be used as keys to look up translations into other languages,
|
||||
so think twice before editing them.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
my @all_test_modules;
|
||||
|
||||
BEGIN {
|
||||
@all_test_modules = split /\n/, read_file( dist_file( 'Zonemaster-Engine', 'modules.txt' ) );
|
||||
|
||||
for my $name ( @all_test_modules ) {
|
||||
require sprintf q{Zonemaster/Engine/Test/%s.pm}, $name;
|
||||
"Zonemaster::Engine::Test::$name"->import();
|
||||
}
|
||||
}
|
||||
|
||||
=head1 INTERNAL METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item _log_versions()
|
||||
|
||||
_log_versions();
|
||||
|
||||
Adds logging messages regarding the current version of some modules, specifically for L<Zonemaster::Engine> and other dependency modules (e.g. L<Zonemaster::LDNS>).
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _log_versions {
|
||||
info( GLOBAL_VERSION => { version => Zonemaster::Engine->VERSION } );
|
||||
|
||||
info( DEPENDENCY_VERSION => { name => 'Zonemaster::LDNS', version => $Zonemaster::LDNS::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'IO::Socket::INET6', version => $IO::Socket::INET6::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'Module::Find', version => $Module::Find::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'File::ShareDir', version => $File::ShareDir::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'File::Slurp', version => $File::Slurp::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'Net::IP::XS', version => $Net::IP::XS::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'List::MoreUtils', version => $List::MoreUtils::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'Clone', version => $Clone::VERSION } );
|
||||
info( DEPENDENCY_VERSION => { name => 'Readonly', version => $Readonly::VERSION } );
|
||||
|
||||
return;
|
||||
} ## end sub _log_versions
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item modules()
|
||||
|
||||
my @modules_array = modules();
|
||||
|
||||
Returns a list of strings containing the names of all available Test modules,
|
||||
based on the content of the B<share/modules.txt> file.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub modules {
|
||||
return @all_test_modules;
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item run_all_for()
|
||||
|
||||
my @logentry_array = run_all_for( $zone );
|
||||
|
||||
Runs the L<default set of tests|/all()> of L<all Test modules found|/modules()> for the given zone.
|
||||
|
||||
Test modules are L<looked up and loaded|/modules()> from the
|
||||
B<share/modules.txt> file, and executed in the order in which they appear in the
|
||||
file.
|
||||
The default set of tests (Test Cases) is specified in the L</all()> method of each Test module. They
|
||||
can be individually disabled by the L<profile|Zonemaster::Engine::Profile/test_cases>.
|
||||
|
||||
A test module may implement a C<can_continue()> method to indicate lack of an
|
||||
extremely minimal level of function for the zone (e.g., it must have a parent
|
||||
domain, and it must have at least one functional name server).
|
||||
If lack of such minimal function is indicated, the testing harness is aborted.
|
||||
See L<Zonemaster::Engine::Test::Basic/can_continue()> for an example.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub run_all_for {
|
||||
my ( $class, $zone ) = @_;
|
||||
my @results;
|
||||
|
||||
Zonemaster::Engine->start_time_now();
|
||||
push @results, info( START_TIME => { time_t => time(), string => strftime( "%F %T %z", ( localtime() ) ) } );
|
||||
push @results, info( TEST_TARGET => { zone => $zone->name->string, module => 'all' } );
|
||||
_log_versions();
|
||||
|
||||
if ( not( Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) or Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) ) {
|
||||
return info( NO_NETWORK => {} );
|
||||
}
|
||||
|
||||
if ( Zonemaster::Engine->can_continue() ) {
|
||||
foreach my $mod ( __PACKAGE__->modules ) {
|
||||
my $module = "Zonemaster::Engine::Test::$mod";
|
||||
|
||||
info( MODULE_VERSION => { module => $module, version => $module->version } );
|
||||
|
||||
my @module_results = eval { $module->all( $zone ) };
|
||||
push @results, @module_results;
|
||||
if ( $@ ) {
|
||||
my $err = $@;
|
||||
if ( blessed $err and $err->isa( 'Zonemaster::Engine::Exception' ) ) {
|
||||
die $err; # Utility exception, pass it on
|
||||
}
|
||||
else {
|
||||
push @results, info( MODULE_ERROR => { module => $module, msg => "$err" } );
|
||||
}
|
||||
}
|
||||
|
||||
info( MODULE_END => { module => $module } );
|
||||
|
||||
if ( $module->can( 'can_continue' ) && !$module->can_continue( $zone, @module_results ) ) {
|
||||
push @results, info( CANNOT_CONTINUE => { domain => $zone->name->string } );
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @results;
|
||||
} ## end sub run_all_for
|
||||
|
||||
=over
|
||||
|
||||
=item run_module()
|
||||
|
||||
my @logentry_array = run_module( $module, $zone );
|
||||
|
||||
Runs the L<default set of tests|/all()> of the given Test module for the given zone.
|
||||
|
||||
The Test module must be in the list of actively loaded modules (that is,
|
||||
a module defined in the B<share/modules.txt> file).
|
||||
The default set of tests (Test Cases) is specified in the L</all()> method of each Test module.
|
||||
They can be individually disabled by the L<profile|Zonemaster::Engine::Profile/test_cases>.
|
||||
|
||||
Takes a string (module name) and a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub run_module {
|
||||
my ( $class, $requested, $zone ) = @_;
|
||||
my @res;
|
||||
my ( $module ) = grep { lc( $requested ) eq lc( $_ ) } $class->modules;
|
||||
|
||||
Zonemaster::Engine->start_time_now();
|
||||
push @res, info( START_TIME => { time_t => time(), string => strftime( "%F %T %z", ( localtime() ) ) } );
|
||||
push @res, info( TEST_TARGET => { zone => $zone->name->string, module => $requested } );
|
||||
_log_versions();
|
||||
|
||||
if ( not( Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) or Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) ) {
|
||||
return info( NO_NETWORK => {} );
|
||||
}
|
||||
|
||||
if ( Zonemaster::Engine->can_continue() ) {
|
||||
if ( $module ) {
|
||||
my $m = "Zonemaster::Engine::Test::$module";
|
||||
info( MODULE_VERSION => { module => $m, version => $m->version } );
|
||||
push @res, eval { $m->all( $zone ) };
|
||||
if ( $@ ) {
|
||||
my $err = $@;
|
||||
if ( blessed $err and $err->isa( 'Zonemaster::Engine::Exception' ) ) {
|
||||
die $err; # Utility exception, pass it on
|
||||
}
|
||||
else {
|
||||
push @res, info( MODULE_ERROR => { module => $module, msg => "$err" } );
|
||||
}
|
||||
}
|
||||
info( MODULE_END => { module => $module } );
|
||||
return @res;
|
||||
}
|
||||
else {
|
||||
info( UNKNOWN_MODULE => { module => $requested, testcase => 'all', module_list => join( ':', sort $class->modules ) } );
|
||||
}
|
||||
}
|
||||
else {
|
||||
info( CANNOT_CONTINUE => { domain => $zone->name->string } );
|
||||
}
|
||||
|
||||
return;
|
||||
} ## end sub run_module
|
||||
|
||||
=over
|
||||
|
||||
=item run_one()
|
||||
|
||||
my @logentry_array = run_one( $module, $test_case, $zone );
|
||||
|
||||
Runs the given Test Case of the given Test module for the given zone.
|
||||
|
||||
The Test module must be in the list of actively loaded modules (that is,
|
||||
a module defined in the B<share/modules.txt> file), and the Test Case
|
||||
must be listed both in the L<metadata|/metadata()> of the Test module
|
||||
exports and in the L<profile|Zonemaster::Engine::Profile/test_cases>.
|
||||
|
||||
Takes a string (module name), a string (test case name) and an array of L<Zonemaster::Engine::Zone> objects.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub run_one {
|
||||
my ( $class, $requested, $test, $zone ) = @_;
|
||||
my @res;
|
||||
my ( $module ) = grep { lc( $requested ) eq lc( $_ ) } $class->modules;
|
||||
|
||||
Zonemaster::Engine->start_time_now();
|
||||
push @res, info( START_TIME => { time_t => time(), string => strftime( "%F %T %z", ( localtime() ) ) } );
|
||||
push @res, info( TEST_TARGET => { zone => $zone->name->string, module => $requested, testcase => $test } );
|
||||
_log_versions();
|
||||
|
||||
if ( not( Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) or Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) ) {
|
||||
return info( NO_NETWORK => {} );
|
||||
}
|
||||
|
||||
if ( Zonemaster::Engine->can_continue() ) {
|
||||
if ( $module ) {
|
||||
my $m = "Zonemaster::Engine::Test::$module";
|
||||
if ( $m->metadata->{$test} and Zonemaster::Engine::Util::should_run_test( $test ) ) {
|
||||
info( MODULE_VERSION => { module => $m, version => $m->version } );
|
||||
push @res, eval { $m->$test( $zone ) };
|
||||
if ( $@ ) {
|
||||
my $err = $@;
|
||||
if ( blessed $err and $err->isa( 'Zonemaster::Engine::Exception' ) ) {
|
||||
die $err; # Utility exception, pass it on
|
||||
}
|
||||
else {
|
||||
push @res, info( MODULE_ERROR => { module => $module, msg => "$err" } );
|
||||
}
|
||||
}
|
||||
info( MODULE_END => { module => $module } );
|
||||
return @res;
|
||||
}
|
||||
else {
|
||||
info( UNKNOWN_METHOD => { module => $m, testcase => $test } );
|
||||
}
|
||||
}
|
||||
else {
|
||||
info( UNKNOWN_MODULE => { module => $requested, testcase => $test, module_list => join( ':', sort $class->modules ) } );
|
||||
}
|
||||
}
|
||||
else {
|
||||
info( CANNOT_CONTINUE => { domain => $zone->name->string } );
|
||||
}
|
||||
|
||||
return;
|
||||
} ## end sub run_one
|
||||
|
||||
1;
|
||||
546
zonemaster-engine/lib/Zonemaster/Engine/Test/Address.pm
Normal file
546
zonemaster-engine/lib/Zonemaster/Engine/Test/Address.pm
Normal file
@@ -0,0 +1,546 @@
|
||||
package Zonemaster::Engine::Test::Address;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.8");
|
||||
|
||||
use Carp;
|
||||
use List::MoreUtils qw[none any uniq];
|
||||
use Locale::TextDomain qw[Zonemaster-Engine];
|
||||
use Readonly;
|
||||
|
||||
use Zonemaster::Engine::Recursor;
|
||||
use Zonemaster::Engine::Constants qw[:addresses :ip];
|
||||
use Zonemaster::Engine::TestMethods;
|
||||
use Zonemaster::Engine::Util qw[name should_run_test];
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Test::Address - Module implementing tests focused on IP addresses of name servers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @results = Zonemaster::Engine::Test::Address->all( $zone );
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item all()
|
||||
|
||||
my @logentry_array = all( $zone );
|
||||
|
||||
Runs the default set of tests for that module, i.e. between L<two and three tests|/TESTS> depending on the tested zone.
|
||||
If L<ADDRESS02|/address02()> passes, L<ADDRESS03|/address03()> is run.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub all {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my @results;
|
||||
|
||||
push @results, $class->address01( $zone )
|
||||
if should_run_test( q{address01} );
|
||||
|
||||
my $ns_with_reverse = 1;
|
||||
if ( should_run_test( q{address02} ) ) {
|
||||
push @results, $class->address02( $zone );
|
||||
$ns_with_reverse = any { $_->tag eq q{NAMESERVERS_IP_WITH_REVERSE} } @results;
|
||||
}
|
||||
|
||||
# Perform ADDRESS03 if ADDRESS02 passed or was skipped
|
||||
if ( $ns_with_reverse ) {
|
||||
push @results, $class->address03( $zone )
|
||||
if should_run_test( q{address03} );
|
||||
}
|
||||
|
||||
return @results;
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item metadata()
|
||||
|
||||
my $hash_ref = metadata();
|
||||
|
||||
Returns a reference to a hash, the keys of which are the names of all Test Cases in the module, and the corresponding values are references to
|
||||
an array containing all the message tags that the Test Case can use in L<log entries|Zonemaster::Engine::Logger::Entry>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub metadata {
|
||||
my ( $class ) = @_;
|
||||
|
||||
return {
|
||||
address01 => [
|
||||
qw(
|
||||
A01_ADDR_NOT_GLOBALLY_REACHABLE
|
||||
A01_DOCUMENTATION_ADDR
|
||||
A01_GLOBALLY_REACHABLE_ADDR
|
||||
A01_LOCAL_USE_ADDR
|
||||
A01_NO_GLOBALLY_REACHABLE_ADDR
|
||||
A01_NO_NAME_SERVERS_FOUND
|
||||
)
|
||||
],
|
||||
address02 => [
|
||||
qw(
|
||||
NAMESERVER_IP_WITHOUT_REVERSE
|
||||
NAMESERVERS_IP_WITH_REVERSE
|
||||
NO_RESPONSE_PTR_QUERY
|
||||
TEST_CASE_END
|
||||
TEST_CASE_START
|
||||
)
|
||||
],
|
||||
address03 => [
|
||||
qw(
|
||||
NAMESERVER_IP_WITHOUT_REVERSE
|
||||
NAMESERVER_IP_PTR_MISMATCH
|
||||
NAMESERVER_IP_PTR_MATCH
|
||||
NO_RESPONSE_PTR_QUERY
|
||||
TEST_CASE_END
|
||||
TEST_CASE_START
|
||||
)
|
||||
],
|
||||
};
|
||||
} ## end sub metadata
|
||||
|
||||
Readonly my %TAG_DESCRIPTIONS => (
|
||||
ADDRESS01 => sub {
|
||||
__x # ADDRESS:ADDRESS01
|
||||
'Name server address must be globally reachable';
|
||||
},
|
||||
ADDRESS02 => sub {
|
||||
__x # ADDRESS:ADDRESS02
|
||||
'Reverse DNS entry exists for name server IP address';
|
||||
},
|
||||
ADDRESS03 => sub {
|
||||
__x # ADDRESS:ADDRESS03
|
||||
'Reverse DNS entry matches name server name';
|
||||
},
|
||||
A01_ADDR_NOT_GLOBALLY_REACHABLE => sub {
|
||||
__x # ADDRESS:A01_ADDR_NOT_GLOBALLY_REACHABLE
|
||||
'IP address(es) not listed as globally reachable: "{ns_list}".', @_;
|
||||
},
|
||||
A01_DOCUMENTATION_ADDR => sub {
|
||||
__x # ADDRESS:A01_DOCUMENTATION_ADDR
|
||||
'IP address(es) intended for documentation purposes: "{ns_list}".', @_;
|
||||
},
|
||||
A01_GLOBALLY_REACHABLE_ADDR => sub {
|
||||
__x # ADDRESS:A01_GLOBALLY_REACHABLE_ADDR
|
||||
'Globally reachable IP address(es): "{ns_list}".', @_;
|
||||
},
|
||||
A01_LOCAL_USE_ADDR => sub {
|
||||
__x # ADDRESS:A01_LOCAL_USE_ADDR
|
||||
'IP address(es) intended for local use on network or service provider level: "{ns_list}".', @_;
|
||||
},
|
||||
A01_NO_GLOBALLY_REACHABLE_ADDR => sub {
|
||||
__x # ADDRESS:A01_NO_GLOBALLY_REACHABLE_ADDR
|
||||
'None of the name servers IP addresses are listed as globally reachable.';
|
||||
},
|
||||
A01_NO_NAME_SERVERS_FOUND => sub {
|
||||
__x # ADDRESS:A01_NO_NAME_SERVERS_FOUND
|
||||
'No name servers found.';
|
||||
},
|
||||
NAMESERVER_IP_WITHOUT_REVERSE => sub {
|
||||
__x # ADDRESS:NAMESERVER_IP_WITHOUT_REVERSE
|
||||
'Nameserver {nsname} has an IP address ({ns_ip}) without PTR configured.', @_;
|
||||
},
|
||||
NAMESERVER_IP_PTR_MISMATCH => sub {
|
||||
__x # ADDRESS:NAMESERVER_IP_PTR_MISMATCH
|
||||
'Nameserver {nsname} has an IP address ({ns_ip}) with mismatched PTR result ({names}).', @_;
|
||||
},
|
||||
NAMESERVERS_IP_WITH_REVERSE => sub {
|
||||
__x # ADDRESS:NAMESERVERS_IP_WITH_REVERSE
|
||||
"Reverse DNS entry exists for each Nameserver IP address.", @_;
|
||||
},
|
||||
NAMESERVER_IP_PTR_MATCH => sub {
|
||||
__x # ADDRESS:NAMESERVER_IP_PTR_MATCH
|
||||
"Every reverse DNS entry matches name server name.", @_;
|
||||
},
|
||||
NO_RESPONSE_PTR_QUERY => sub {
|
||||
__x # ADDRESS:NO_RESPONSE_PTR_QUERY
|
||||
'No response from nameserver(s) on PTR query ({domain}).', @_;
|
||||
},
|
||||
TEST_CASE_END => sub {
|
||||
__x # ADDRESS:TEST_CASE_END
|
||||
'TEST_CASE_END {testcase}.', @_;
|
||||
},
|
||||
TEST_CASE_START => sub {
|
||||
__x # ADDRESS:TEST_CASE_START
|
||||
'TEST_CASE_START {testcase}.', @_;
|
||||
},
|
||||
);
|
||||
|
||||
=over
|
||||
|
||||
=item tag_descriptions()
|
||||
|
||||
my $hash_ref = tag_descriptions();
|
||||
|
||||
Used by the L<built-in translation system|Zonemaster::Engine::Translator>.
|
||||
|
||||
Returns a reference to a hash, the keys of which are the message tags and the corresponding values are strings (message IDs).
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub tag_descriptions {
|
||||
return \%TAG_DESCRIPTIONS;
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item version()
|
||||
|
||||
my $version_string = version();
|
||||
|
||||
Returns a string containing the version of the current module.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub version {
|
||||
return "$Zonemaster::Engine::Test::Address::VERSION";
|
||||
}
|
||||
|
||||
=head1 INTERNAL METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item _emit_log()
|
||||
|
||||
my $log_entry = _emit_log( $message_tag_string, $hash_ref );
|
||||
|
||||
Adds a message to the L<logger|Zonemaster::Engine::Logger> for this module.
|
||||
See L<Zonemaster::Engine::Logger::Entry/add($tag, $argref, $module, $testcase)> for more details.
|
||||
|
||||
Takes a string (message tag) and a reference to a hash (arguments).
|
||||
|
||||
Returns a L<Zonemaster::Engine::Logger::Entry> object.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _emit_log { my ( $tag, $argref ) = @_; return Zonemaster::Engine->logger->add( $tag, $argref, 'Address' ); }
|
||||
|
||||
=over
|
||||
|
||||
=item _find_special_address()
|
||||
|
||||
my $hash_ref = _find_special_address( $ip );
|
||||
|
||||
Verifies if an IP address is a special (private, reserved, ...) one.
|
||||
|
||||
Takes a L<Net::IP::XS> object.
|
||||
|
||||
Returns a reference to a hash if true (see L<Zonemaster::Engine::Constants/_extract_iana_ip_blocks()>), or C<undef> if false.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _find_special_address {
|
||||
my ( $class, $ip ) = @_;
|
||||
my @special_addresses;
|
||||
|
||||
if ( $ip->version == $IP_VERSION_4 ) {
|
||||
@special_addresses = @IPV4_SPECIAL_ADDRESSES;
|
||||
}
|
||||
elsif ( $ip->version == $IP_VERSION_6 ) {
|
||||
@special_addresses = @IPV6_SPECIAL_ADDRESSES;
|
||||
}
|
||||
|
||||
foreach my $ip_details ( @special_addresses ) {
|
||||
if ( $ip->overlaps( ${$ip_details}{ip} ) ) {
|
||||
return $ip_details;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
=head1 TESTS
|
||||
|
||||
=over
|
||||
|
||||
=item address01()
|
||||
|
||||
my @logentry_array = address01( $zone );
|
||||
|
||||
Runs the L<Address01 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Address-TP/address01.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub address01 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Address01';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
|
||||
my @nss = uniq grep { $_->isa('Zonemaster::Engine::Nameserver') } (
|
||||
@{ Zonemaster::Engine::TestMethodsV2->get_del_ns_names_and_ips( $zone ) // [] },
|
||||
@{ Zonemaster::Engine::TestMethodsV2->get_zone_ns_names_and_ips( $zone ) // [] }
|
||||
);
|
||||
|
||||
unless ( @nss ) {
|
||||
push @results, _emit_log( A01_NO_NAME_SERVERS_FOUND => {} );
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
}
|
||||
|
||||
my ( @documentation_addr, @local_use_addr, @not_globally_reachable, @globally_reachable );
|
||||
my %ip_already_processed;
|
||||
|
||||
NSS:
|
||||
foreach my $ns ( @nss ) {
|
||||
my $ns_ip = $ns->address->short;
|
||||
|
||||
next if exists $ip_already_processed{$ns_ip};
|
||||
$ip_already_processed{$ns_ip} = [ grep { $_->address->short eq $ns_ip } @nss ];
|
||||
|
||||
my @matching_nss = @{ $ip_already_processed{$ns_ip} };
|
||||
|
||||
my $ip_details_ref = $class->_find_special_address( $ns->address );
|
||||
|
||||
if ( $ip_details_ref ) {
|
||||
my $ip_category = ${$ip_details_ref}{name};
|
||||
|
||||
if ( index( $ip_category, 'Documentation' ) != -1 ) {
|
||||
push @documentation_addr, @matching_nss;
|
||||
next;
|
||||
}
|
||||
|
||||
my @categories = ( 'Private-Use', 'Loopback', 'Link Local', 'Link-Local', 'Unique-Local', 'Shared Address Space' );
|
||||
foreach my $category ( @categories ) {
|
||||
if ( index( $ip_category, $category ) != -1 ) {
|
||||
push @local_use_addr, @matching_nss;
|
||||
next NSS;
|
||||
}
|
||||
}
|
||||
|
||||
if ( index( ${$ip_details_ref}{globally_reachable}, 'True' ) == -1 ) {
|
||||
push @not_globally_reachable, @matching_nss;
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
push @globally_reachable, @matching_nss;
|
||||
}
|
||||
|
||||
if ( @globally_reachable ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
A01_GLOBALLY_REACHABLE_ADDR => {
|
||||
ns_list => join( q{;}, uniq sort @globally_reachable )
|
||||
}
|
||||
);
|
||||
}
|
||||
else {
|
||||
push @results,
|
||||
_emit_log(
|
||||
A01_NO_GLOBALLY_REACHABLE_ADDR => {}
|
||||
);
|
||||
}
|
||||
|
||||
if ( @documentation_addr ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
A01_DOCUMENTATION_ADDR => {
|
||||
ns_list => join( q{;}, uniq sort @documentation_addr )
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
if ( @local_use_addr ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
A01_LOCAL_USE_ADDR => {
|
||||
ns_list => join( q{;}, uniq sort @local_use_addr )
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
if ( @not_globally_reachable ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
A01_ADDR_NOT_GLOBALLY_REACHABLE => {
|
||||
ns_list => join( q{;}, uniq sort @not_globally_reachable )
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub address01
|
||||
|
||||
=over
|
||||
|
||||
=item address02()
|
||||
|
||||
my @logentry_array = address02( $zone );
|
||||
|
||||
Runs the L<Address02 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Address-TP/address02.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub address02 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Address02';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
|
||||
my %ips;
|
||||
my $ptr_query;
|
||||
|
||||
foreach
|
||||
my $local_ns ( @{ Zonemaster::Engine::TestMethods->method4( $zone ) }, @{ Zonemaster::Engine::TestMethods->method5( $zone ) } )
|
||||
{
|
||||
|
||||
next if $ips{ $local_ns->address->short };
|
||||
|
||||
my $reverse_ip_query = $local_ns->address->reverse_ip;
|
||||
$ptr_query = $reverse_ip_query;
|
||||
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ptr_query, q{PTR} );
|
||||
|
||||
# In case of Classless IN-ADDR.ARPA delegation, query returns
|
||||
# CNAME records. A PTR query is done on the CNAME.
|
||||
if ( $p and $p->rcode eq q{NOERROR} and $p->get_records( q{CNAME}, q{answer} ) ) {
|
||||
my ( $cname ) = $p->get_records( q{CNAME}, q{answer} );
|
||||
$ptr_query = $cname->cname;
|
||||
$p = Zonemaster::Engine::Recursor->recurse( $ptr_query, q{PTR} );
|
||||
}
|
||||
|
||||
if ( $p ) {
|
||||
if ( $p->rcode ne q{NOERROR} or not $p->get_records( q{PTR}, q{answer} ) ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
NAMESERVER_IP_WITHOUT_REVERSE => {
|
||||
nsname => $local_ns->name->string,
|
||||
ns_ip => $local_ns->address->short,
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @results,
|
||||
_emit_log(
|
||||
NO_RESPONSE_PTR_QUERY => {
|
||||
domain => $ptr_query,
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
$ips{ $local_ns->address->short }++;
|
||||
|
||||
} ## end foreach my $local_ns ( @{ Zonemaster::Engine::TestMethods...})
|
||||
|
||||
if ( scalar keys %ips and not grep { $_->tag ne q{TEST_CASE_START} } @results ) {
|
||||
push @results, _emit_log( NAMESERVERS_IP_WITH_REVERSE => {} );
|
||||
}
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub address02
|
||||
|
||||
=over
|
||||
|
||||
=item address03()
|
||||
|
||||
my @logentry_array = address03( $zone );
|
||||
|
||||
Runs the L<Address03 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Address-TP/address03.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub address03 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Address03';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
my $ptr_query;
|
||||
|
||||
my %ips;
|
||||
|
||||
foreach my $local_ns ( @{ Zonemaster::Engine::TestMethods->method5( $zone ) } ) {
|
||||
|
||||
next if $ips{ $local_ns->address->short };
|
||||
|
||||
my $reverse_ip_query = $local_ns->address->reverse_ip;
|
||||
$ptr_query = $reverse_ip_query;
|
||||
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ptr_query, q{PTR} );
|
||||
|
||||
if ( $p ) {
|
||||
my @ptr = $p->get_records( q{PTR}, 'answer' );
|
||||
if ( $p->rcode eq q{NOERROR} and scalar @ptr ) {
|
||||
if ( none { name( $_->ptrdname ) eq $local_ns->name->string . q{.} } @ptr ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
NAMESERVER_IP_PTR_MISMATCH => {
|
||||
nsname => $local_ns->name->string,
|
||||
ns_ip => $local_ns->address->short,
|
||||
names => join( q{/}, map { $_->ptrdname } @ptr ),
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @results,
|
||||
_emit_log(
|
||||
NAMESERVER_IP_WITHOUT_REVERSE => {
|
||||
nsname => $local_ns->name->string,
|
||||
ns_ip => $local_ns->address->short,
|
||||
}
|
||||
);
|
||||
}
|
||||
} ## end if ( $p )
|
||||
else {
|
||||
push @results,
|
||||
_emit_log(
|
||||
NO_RESPONSE_PTR_QUERY => {
|
||||
domain => $ptr_query,
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
$ips{ $local_ns->address->short }++;
|
||||
|
||||
} ## end foreach my $local_ns ( @{ Zonemaster::Engine::TestMethods...})
|
||||
|
||||
if ( scalar keys %ips and not grep { $_->tag ne q{TEST_CASE_START} } @results ) {
|
||||
push @results, _emit_log( NAMESERVER_IP_PTR_MATCH => {} );
|
||||
}
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub address03
|
||||
|
||||
1;
|
||||
1131
zonemaster-engine/lib/Zonemaster/Engine/Test/Basic.pm
Normal file
1131
zonemaster-engine/lib/Zonemaster/Engine/Test/Basic.pm
Normal file
File diff suppressed because it is too large
Load Diff
901
zonemaster-engine/lib/Zonemaster/Engine/Test/Connectivity.pm
Normal file
901
zonemaster-engine/lib/Zonemaster/Engine/Test/Connectivity.pm
Normal file
@@ -0,0 +1,901 @@
|
||||
package Zonemaster::Engine::Test::Connectivity;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.1.0");
|
||||
|
||||
use Carp;
|
||||
use List::MoreUtils qw[uniq];
|
||||
use Locale::TextDomain qw[Zonemaster-Engine];
|
||||
use Readonly;
|
||||
|
||||
use Zonemaster::Engine::Profile;
|
||||
use Zonemaster::Engine::ASNLookup;
|
||||
use Zonemaster::Engine::Constants qw[:ip];
|
||||
use Zonemaster::Engine::TestMethods;
|
||||
use Zonemaster::Engine::TestMethodsV2;
|
||||
use Zonemaster::Engine::Util;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Test::Connectivity - Module implementing tests focused on name servers reachability
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @results = Zonemaster::Engine::Test::Connectivity->all( $zone );
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item all()
|
||||
|
||||
my @array = all( $zone );
|
||||
|
||||
Runs the default set of tests for that module, i.e. L<four tests|/TESTS>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub all {
|
||||
my ( $class, $zone ) = @_;
|
||||
my @results;
|
||||
|
||||
if ( Zonemaster::Engine::Util::should_run_test( q{connectivity01} ) ) {
|
||||
push @results, $class->connectivity01( $zone );
|
||||
}
|
||||
if ( Zonemaster::Engine::Util::should_run_test( q{connectivity02} ) ) {
|
||||
push @results, $class->connectivity02( $zone );
|
||||
}
|
||||
if ( Zonemaster::Engine::Util::should_run_test( q{connectivity03} ) ) {
|
||||
push @results, $class->connectivity03( $zone );
|
||||
}
|
||||
if ( Zonemaster::Engine::Util::should_run_test( q{connectivity04} ) ) {
|
||||
push @results, $class->connectivity04( $zone );
|
||||
}
|
||||
|
||||
return @results;
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item metadata()
|
||||
|
||||
my $hash_ref = metadata();
|
||||
|
||||
Returns a reference to a hash, the keys of which are the names of all Test Cases in the module, and the corresponding values are references to
|
||||
an array containing all the message tags that the Test Case can use in L<log entries|Zonemaster::Engine::Logger::Entry>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub metadata {
|
||||
my ( $class ) = @_;
|
||||
|
||||
return {
|
||||
connectivity01 => [
|
||||
qw(
|
||||
CN01_IPV4_DISABLED
|
||||
CN01_IPV6_DISABLED
|
||||
CN01_MISSING_NS_RECORD_UDP
|
||||
CN01_MISSING_SOA_RECORD_UDP
|
||||
CN01_NO_RESPONSE_NS_QUERY_UDP
|
||||
CN01_NO_RESPONSE_SOA_QUERY_UDP
|
||||
CN01_NO_RESPONSE_UDP
|
||||
CN01_NS_RECORD_NOT_AA_UDP
|
||||
CN01_SOA_RECORD_NOT_AA_UDP
|
||||
CN01_UNEXPECTED_RCODE_NS_QUERY_UDP
|
||||
CN01_UNEXPECTED_RCODE_SOA_QUERY_UDP
|
||||
CN01_WRONG_NS_RECORD_UDP
|
||||
CN01_WRONG_SOA_RECORD_UDP
|
||||
IPV4_DISABLED
|
||||
IPV6_DISABLED
|
||||
TEST_CASE_END
|
||||
TEST_CASE_START
|
||||
)
|
||||
],
|
||||
connectivity02 => [
|
||||
qw(
|
||||
CN02_MISSING_NS_RECORD_TCP
|
||||
CN02_MISSING_SOA_RECORD_TCP
|
||||
CN02_NO_RESPONSE_NS_QUERY_TCP
|
||||
CN02_NO_RESPONSE_SOA_QUERY_TCP
|
||||
CN02_NO_RESPONSE_TCP
|
||||
CN02_NS_RECORD_NOT_AA_TCP
|
||||
CN02_SOA_RECORD_NOT_AA_TCP
|
||||
CN02_UNEXPECTED_RCODE_NS_QUERY_TCP
|
||||
CN02_UNEXPECTED_RCODE_SOA_QUERY_TCP
|
||||
CN02_WRONG_NS_RECORD_TCP
|
||||
CN02_WRONG_SOA_RECORD_TCP
|
||||
IPV4_DISABLED
|
||||
IPV6_DISABLED
|
||||
TEST_CASE_END
|
||||
TEST_CASE_START
|
||||
)
|
||||
],
|
||||
connectivity03 => [
|
||||
qw(
|
||||
ASN_INFOS_RAW
|
||||
ASN_INFOS_ANNOUNCE_BY
|
||||
ASN_INFOS_ANNOUNCE_IN
|
||||
EMPTY_ASN_SET
|
||||
ERROR_ASN_DATABASE
|
||||
IPV4_DIFFERENT_ASN
|
||||
IPV4_ONE_ASN
|
||||
IPV4_SAME_ASN
|
||||
IPV6_DIFFERENT_ASN
|
||||
IPV6_ONE_ASN
|
||||
IPV6_SAME_ASN
|
||||
TEST_CASE_END
|
||||
TEST_CASE_START
|
||||
)
|
||||
],
|
||||
connectivity04 => [
|
||||
qw(
|
||||
ASN_INFOS_RAW
|
||||
ASN_INFOS_ANNOUNCE_IN
|
||||
CN04_EMPTY_PREFIX_SET
|
||||
CN04_ERROR_PREFIX_DATABASE
|
||||
CN04_IPV4_DIFFERENT_PREFIX
|
||||
CN04_IPV4_SAME_PREFIX
|
||||
CN04_IPV4_SINGLE_PREFIX
|
||||
CN04_IPV6_DIFFERENT_PREFIX
|
||||
CN04_IPV6_SAME_PREFIX
|
||||
CN04_IPV6_SINGLE_PREFIX
|
||||
TEST_CASE_END
|
||||
TEST_CASE_START
|
||||
)
|
||||
],
|
||||
};
|
||||
} ## end sub metadata
|
||||
|
||||
Readonly my %TAG_DESCRIPTIONS => (
|
||||
CONNECTIVITY01 => sub {
|
||||
__x # CONNECTIVITY:CONNECTIVITY01
|
||||
'UDP connectivity';
|
||||
},
|
||||
CONNECTIVITY02 => sub {
|
||||
__x # CONNECTIVITY:CONNECTIVITY02
|
||||
'TCP connectivity';
|
||||
},
|
||||
CONNECTIVITY03 => sub {
|
||||
__x # CONNECTIVITY:CONNECTIVITY03
|
||||
'AS Diversity';
|
||||
},
|
||||
CONNECTIVITY04 => sub {
|
||||
__x # CONNECTIVITY:CONNECTIVITY04
|
||||
'IP Prefix Diversity';
|
||||
},
|
||||
CN01_IPV4_DISABLED => sub {
|
||||
__x # CONNECTIVITY:CN01_IPV4_DISABLED
|
||||
'IPv4 is disabled. No DNS queries are sent to these name servers: "{ns_list}".', @_;
|
||||
},
|
||||
CN01_IPV6_DISABLED => sub {
|
||||
__x # CONNECTIVITY:CN01_IPV6_DISABLED
|
||||
'IPv6 is disabled. No DNS queries are sent to these name servers: "{ns_list}".', @_;
|
||||
},
|
||||
CN01_MISSING_NS_RECORD_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_MISSING_NS_RECORD_UDP
|
||||
'Nameserver {ns} responds to a NS query with no NS records in the answer section over UDP.', @_;
|
||||
},
|
||||
CN01_MISSING_SOA_RECORD_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_MISSING_SOA_RECORD_UDP
|
||||
'Nameserver {ns} responds to a SOA query with no SOA records in the answer section over UDP.', @_;
|
||||
},
|
||||
CN01_NO_RESPONSE_NS_QUERY_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_NO_RESPONSE_NS_QUERY_UDP
|
||||
'Nameserver {ns} does not respond to NS queries over UDP.', @_;
|
||||
},
|
||||
CN01_NO_RESPONSE_SOA_QUERY_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_NO_RESPONSE_SOA_QUERY_UDP
|
||||
'Nameserver {ns} does not respond to SOA queries over UDP.', @_;
|
||||
},
|
||||
CN01_NO_RESPONSE_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_NO_RESPONSE_UDP
|
||||
'Nameserver {ns} does not respond to any queries over UDP.', @_;
|
||||
},
|
||||
CN01_NS_RECORD_NOT_AA_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_NS_RECORD_NOT_AA_UDP
|
||||
'Nameserver {ns} does not give an authoritative response on an NS query over UDP.', @_;
|
||||
},
|
||||
CN01_SOA_RECORD_NOT_AA_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_SOA_RECORD_NOT_AA_UDP
|
||||
'Nameserver {ns} does not give an authoritative response on an SOA query over UDP.', @_;
|
||||
},
|
||||
CN01_UNEXPECTED_RCODE_NS_QUERY_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_UNEXPECTED_RCODE_NS_QUERY_UDP
|
||||
'Nameserver {ns} responds with an unexpected RCODE ({rcode}) on an NS query over UDP.', @_;
|
||||
},
|
||||
CN01_UNEXPECTED_RCODE_SOA_QUERY_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_UNEXPECTED_RCODE_SOA_QUERY_UDP
|
||||
'Nameserver {ns} responds with an unexpected RCODE ({rcode}) on an SOA query over UDP.', @_;
|
||||
},
|
||||
CN01_WRONG_NS_RECORD_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_WRONG_NS_RECORD_UDP
|
||||
'Nameserver {ns} responds with a wrong owner name ({domain_found} instead of {domain_expected}) on NS queries over UDP.', @_;
|
||||
},
|
||||
CN01_WRONG_SOA_RECORD_UDP => sub {
|
||||
__x # CONNECTIVITY:CN01_WRONG_SOA_RECORD_UDP
|
||||
'Nameserver {ns} responds with a wrong owner name ({domain_found} instead of {domain_expected}) on SOA queries over UDP.', @_;
|
||||
},
|
||||
CN02_MISSING_NS_RECORD_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_MISSING_NS_RECORD_TCP
|
||||
'Nameserver {ns} responds to a NS query with no NS records in the answer section over TCP.', @_;
|
||||
},
|
||||
CN02_MISSING_SOA_RECORD_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_MISSING_SOA_RECORD_TCP
|
||||
'Nameserver {ns} responds to a SOA query with no SOA records in the answer section over TCP.', @_;
|
||||
},
|
||||
CN02_NO_RESPONSE_NS_QUERY_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_NO_RESPONSE_NS_QUERY_TCP
|
||||
'Nameserver {ns} does not respond to NS queries over TCP.', @_;
|
||||
},
|
||||
CN02_NO_RESPONSE_SOA_QUERY_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_NO_RESPONSE_SOA_QUERY_TCP
|
||||
'Nameserver {ns} does not respond to SOA queries over TCP.', @_;
|
||||
},
|
||||
CN02_NO_RESPONSE_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_NO_RESPONSE_TCP
|
||||
'Nameserver {ns} does not respond to any queries over TCP.', @_;
|
||||
},
|
||||
CN02_NS_RECORD_NOT_AA_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_NS_RECORD_NOT_AA_TCP
|
||||
'Nameserver {ns} does not give an authoritative response on an NS query over TCP.', @_;
|
||||
},
|
||||
CN02_SOA_RECORD_NOT_AA_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_SOA_RECORD_NOT_AA_TCP
|
||||
'Nameserver {ns} does not give an authoritative response on an SOA query over TCP.', @_;
|
||||
},
|
||||
CN02_UNEXPECTED_RCODE_NS_QUERY_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_UNEXPECTED_RCODE_NS_QUERY_TCP
|
||||
'Nameserver {ns} responds with an unexpected RCODE ({rcode}) on an NS query over TCP.', @_;
|
||||
},
|
||||
CN02_UNEXPECTED_RCODE_SOA_QUERY_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_UNEXPECTED_RCODE_SOA_QUERY_TCP
|
||||
'Nameserver {ns} responds with an unexpected RCODE ({rcode}) on an SOA query over TCP.', @_;
|
||||
},
|
||||
CN02_WRONG_NS_RECORD_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_WRONG_NS_RECORD_TCP
|
||||
'Nameserver {ns} responds with a wrong owner name ({domain_found} instead of {domain_expected}) on NS queries over TCP.', @_;
|
||||
},
|
||||
CN02_WRONG_SOA_RECORD_TCP => sub {
|
||||
__x # CONNECTIVITY:CN02_WRONG_SOA_RECORD_TCP
|
||||
'Nameserver {ns} responds with a wrong owner name ({domain_found} instead of {domain_expected}) on SOA queries over TCP.', @_;
|
||||
},
|
||||
CN04_ASN_INFOS_ANNOUNCE_IN => sub {
|
||||
__x # CONNECTIVITY:ASN_INFOS_ANNOUNCE_IN
|
||||
'Name server IP address "{ns_ip}" is announced in prefix "{prefix}".', @_;
|
||||
},
|
||||
CN04_ASN_INFOS_RAW => sub {
|
||||
__x # CONNECTIVITY:ASN_INFOS_RAW
|
||||
'The ASN data for name server IP address "{ns_ip}" is "{data}".', @_;
|
||||
},
|
||||
CN04_EMPTY_PREFIX_SET => sub {
|
||||
__x # CONNECTIVITY:CN04_EMPTY_PREFIX_SET
|
||||
'Prefix database returned no information for IP address {ns_ip}.', @_;
|
||||
},
|
||||
CN04_ERROR_PREFIX_DATABASE => sub {
|
||||
__x # CONNECTIVITY:CN04_ERROR_PREFIX_DATABASE
|
||||
'Prefix database error for IP address {ns_ip}.', @_;
|
||||
},
|
||||
CN04_IPV4_DIFFERENT_PREFIX => sub {
|
||||
__x # CONNECTIVITY:CN04_IPV4_DIFFERENT_PREFIX
|
||||
'The following name server(s) are announced in unique IPv4 prefix(es): "{ns_list}"', @_;
|
||||
},
|
||||
CN04_IPV4_SAME_PREFIX => sub {
|
||||
__x # CONNECTIVITY:CN04_IPV4_SAME_PREFIX
|
||||
'The following name server(s) are announced in the same IPv4 prefix ({ip_prefix}): "{ns_list}"', @_;
|
||||
},
|
||||
CN04_IPV4_SINGLE_PREFIX => sub {
|
||||
__x # CONNECTIVITY:CN04_IPV4_SINGLE_PREFIX
|
||||
'All name server(s) IPv4 address(es) are announced in the same IPv4 prefix.';
|
||||
},
|
||||
CN04_IPV6_DIFFERENT_PREFIX => sub {
|
||||
__x # CONNECTIVITY:CN04_IPV6_DIFFERENT_PREFIX
|
||||
'The following name server(s) are announced in unique IPv6 prefix(es): "{ns_list}"', @_;
|
||||
},
|
||||
CN04_IPV6_SAME_PREFIX => sub {
|
||||
__x # CONNECTIVITY:CN04_IPV6_SAME_PREFIX
|
||||
'The following name server(s) are announced in the same IPv6 prefix ({ip_prefix}): "{ns_list}"', @_;
|
||||
},
|
||||
CN04_IPV6_SINGLE_PREFIX => sub {
|
||||
__x # CONNECTIVITY:CN04_IPV6_SINGLE_PREFIX
|
||||
'All name server(s) IPv6 address(es) are announced in the same IPv6 prefix.';
|
||||
},
|
||||
ERROR_ASN_DATABASE => sub {
|
||||
__x # CONNECTIVITY:ERROR_ASN_DATABASE
|
||||
'ASN Database error. No data to analyze for {ns_ip}.', @_;
|
||||
},
|
||||
EMPTY_ASN_SET => sub {
|
||||
__x # CONNECTIVITY:EMPTY_ASN_SET
|
||||
'AS database returned no informations for IP address {ns_ip}.', @_;
|
||||
},
|
||||
IPV4_SAME_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV4_SAME_ASN
|
||||
'All authoritative nameservers have their IPv4 addresses in the same AS set ({asn_list}).', @_;
|
||||
},
|
||||
IPV4_ONE_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV4_ONE_ASN
|
||||
'All authoritative nameservers have their IPv4 addresses in the same AS ({asn}).', @_;
|
||||
},
|
||||
IPV4_DIFFERENT_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV4_DIFFERENT_ASN
|
||||
'At least two IPv4 addresses of the authoritative nameservers are announced by different AS sets. '
|
||||
. 'A merged list of all AS: ({asn_list}).', @_;
|
||||
},
|
||||
IPV6_SAME_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV6_SAME_ASN
|
||||
'All authoritative nameservers have their IPv6 addresses in the same AS set ({asn_list}).', @_;
|
||||
},
|
||||
IPV6_ONE_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV6_ONE_ASN
|
||||
'All authoritative nameservers have their IPv6 addresses in the same AS ({asn}).', @_;
|
||||
},
|
||||
IPV6_DIFFERENT_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV6_DIFFERENT_ASN
|
||||
'At least two IPv6 addresses of the authoritative nameservers are announced by different AS sets. '
|
||||
. 'A merged list of all AS: ({asn_list}).', @_;
|
||||
},
|
||||
IPV4_DISABLED => sub {
|
||||
__x # CONNECTIVITY:IPV4_DISABLED
|
||||
'IPv4 is disabled, not sending "{rrtype}" query to {ns}.', @_;
|
||||
},
|
||||
IPV6_DISABLED => sub {
|
||||
__x # CONNECTIVITY:IPV6_DISABLED
|
||||
'IPv6 is disabled, not sending "{rrtype}" query to {ns}.', @_;
|
||||
},
|
||||
IPV4_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV4_ASN
|
||||
'Name servers have IPv4 addresses in the following ASs: {asn}.', @_;
|
||||
},
|
||||
IPV6_ASN => sub {
|
||||
__x # CONNECTIVITY:IPV6_ASN
|
||||
'Name servers have IPv6 addresses in the following ASs: {asn}.', @_;
|
||||
},
|
||||
ASN_INFOS_RAW => sub {
|
||||
__x # CONNECTIVITY:ASN_INFOS_RAW
|
||||
'The ASN data for name server IP address "{ns_ip}" is "{data}".', @_;
|
||||
},
|
||||
ASN_INFOS_ANNOUNCE_BY => sub {
|
||||
__x # CONNECTIVITY:ASN_INFOS_ANNOUNCE_BY
|
||||
'Name server IP address "{ns_ip}" is announced by ASN {asn}.', @_;
|
||||
},
|
||||
ASN_INFOS_ANNOUNCE_IN => sub {
|
||||
__x # CONNECTIVITY:ASN_INFOS_ANNOUNCE_IN
|
||||
'Name server IP address "{ns_ip}" is announced in prefix "{prefix}".', @_;
|
||||
},
|
||||
TEST_CASE_END => sub {
|
||||
__x # CONNECTIVITY:TEST_CASE_END
|
||||
'TEST_CASE_END {testcase}.', @_;
|
||||
},
|
||||
TEST_CASE_START => sub {
|
||||
__x # CONNECTIVITY:TEST_CASE_START
|
||||
'TEST_CASE_START {testcase}.', @_;
|
||||
},
|
||||
);
|
||||
|
||||
=over
|
||||
|
||||
=item tag_descriptions()
|
||||
|
||||
my $hash_ref = tag_descriptions();
|
||||
|
||||
Used by the L<built-in translation system|Zonemaster::Engine::Translator>.
|
||||
|
||||
Returns a reference to a hash, the keys of which are the message tags and the corresponding values are strings (message ids).
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub tag_descriptions {
|
||||
return \%TAG_DESCRIPTIONS;
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item version()
|
||||
|
||||
my $string = version();
|
||||
|
||||
Returns a string containing the version of the current module.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub version {
|
||||
return "$Zonemaster::Engine::Test::Connectivity::VERSION";
|
||||
}
|
||||
|
||||
=head1 INTERNAL METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item _emit_log()
|
||||
|
||||
my $log_entry = _emit_log( $message_tag_string, $hash_ref );
|
||||
|
||||
Adds a message to the L<logger|Zonemaster::Engine::Logger> for this module.
|
||||
See L<Zonemaster::Engine::Logger::Entry/add($tag, $argref, $module, $testcase)> for more details.
|
||||
|
||||
Takes a string (message tag) and a reference to a hash (arguments).
|
||||
|
||||
Returns a L<Zonemaster::Engine::Logger::Entry> object.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _emit_log { my ( $tag, $argref ) = @_; return Zonemaster::Engine->logger->add( $tag, $argref, 'Connectivity' ); }
|
||||
|
||||
=over
|
||||
|
||||
=item _ip_disabled_message()
|
||||
|
||||
my $bool = _ip_disabled_message( $logentry_array_ref, $ns, @query_type_array );
|
||||
|
||||
Checks if the IP version of a given name server is allowed to be queried. If not, it adds a logging message and returns true. Else, it returns false.
|
||||
|
||||
Takes a reference to an array of L<Zonemaster::Engine::Logger::Entry> objects, a L<Zonemaster::Engine::Nameserver> object and an array of strings (query type).
|
||||
|
||||
Returns a boolean.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _ip_disabled_message {
|
||||
my ( $results_array, $ns, @rrtypes ) = @_;
|
||||
|
||||
if ( not Zonemaster::Engine::Profile->effective->get(q{net.ipv6}) and $ns->address->version == $IP_VERSION_6 ) {
|
||||
push @$results_array, map {
|
||||
_emit_log(
|
||||
IPV6_DISABLED => {
|
||||
ns => $ns->string,
|
||||
rrtype => $_
|
||||
}
|
||||
)
|
||||
} @rrtypes;
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ( not Zonemaster::Engine::Profile->effective->get(q{net.ipv4}) and $ns->address->version == $IP_VERSION_4 ) {
|
||||
push @$results_array, map {
|
||||
_emit_log(
|
||||
IPV4_DISABLED => {
|
||||
ns => $ns->string,
|
||||
rrtype => $_,
|
||||
}
|
||||
)
|
||||
} @rrtypes;
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item _connectivity_loop()
|
||||
|
||||
_connectivity_loop( $testcase_string, $zone_name, $ns_array_ref, $logentry_array_ref );
|
||||
|
||||
Verifies name servers reachability. Used as an helper function for Test Cases L<Connectivity01/connectivity01()>
|
||||
and L<Connectivity02/connectivity02()>.
|
||||
|
||||
Takes a string (test case identifier), a L<Zonemaster::Engine::DNSName> object, a reference to an array of L<Zonemaster::Engine::Nameserver>
|
||||
objects and a reference to an array of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _connectivity_loop {
|
||||
my ( $testcase, $name, $ns_list, $results ) = @_;
|
||||
|
||||
my ( $testcase_prefix, $use_tcp, $protocol );
|
||||
if ( $testcase eq 'connectivity01' ) {
|
||||
( $testcase_prefix, $use_tcp, $protocol ) = ( "CN01", 0, "UDP" );
|
||||
} elsif ( $testcase eq 'connectivity02' ) {
|
||||
( $testcase_prefix, $use_tcp, $protocol ) = ( "CN02", 1, "TCP" );
|
||||
}
|
||||
|
||||
foreach my $ns ( @$ns_list ) {
|
||||
if ( _ip_disabled_message( $results, $ns, qw{SOA NS} ) ) {
|
||||
next;
|
||||
}
|
||||
|
||||
my %packets = (
|
||||
'SOA' => $ns->query( $name, q{SOA}, { usevc => $use_tcp } ),
|
||||
'NS' => $ns->query( $name, q{NS}, { usevc => $use_tcp } )
|
||||
);
|
||||
|
||||
if ( not $packets{SOA} and not $packets{NS} ) {
|
||||
push @$results, _emit_log( "${testcase_prefix}_NO_RESPONSE_${protocol}" => { ns => $ns->string } );
|
||||
next;
|
||||
}
|
||||
|
||||
foreach my $qtype ( qw{SOA NS} ) {
|
||||
my $pkt = $packets{$qtype};
|
||||
|
||||
if ( not $pkt ) {
|
||||
push @$results, _emit_log( "${testcase_prefix}_NO_RESPONSE_${qtype}_QUERY_${protocol}" => { ns => $ns->string } );
|
||||
}
|
||||
elsif ( $pkt->rcode ne q{NOERROR} ) {
|
||||
push @$results, _emit_log( "${testcase_prefix}_UNEXPECTED_RCODE_${qtype}_QUERY_${protocol}" => {
|
||||
ns => $ns->string,
|
||||
rcode => $pkt->rcode
|
||||
}
|
||||
);
|
||||
}
|
||||
else {
|
||||
my ( $rr ) = $pkt->get_records( $qtype, q{answer} );
|
||||
if ( not $rr ) {
|
||||
push @$results, _emit_log( "${testcase_prefix}_MISSING_${qtype}_RECORD_${protocol}" => { ns => $ns->string } );
|
||||
}
|
||||
elsif ( lc($rr->owner) ne lc($name->fqdn) ) {
|
||||
push @$results, _emit_log( "${testcase_prefix}_WRONG_${qtype}_RECORD_${protocol}" => {
|
||||
ns => $ns->string,
|
||||
domain_found => lc($rr->owner),
|
||||
domain_expected => lc($name->fqdn)
|
||||
}
|
||||
);
|
||||
}
|
||||
elsif ( not $pkt->aa ) {
|
||||
push @$results, _emit_log( "${testcase_prefix}_${qtype}_RECORD_NOT_AA_${protocol}" => { ns => $ns->string } );
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head1 TESTS
|
||||
|
||||
=over
|
||||
|
||||
=item connectivity01()
|
||||
|
||||
my @logentry_array = connectivity01( $zone );
|
||||
|
||||
Runs the L<Connectivity01 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Connectivity-TP/connectivity01.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub connectivity01 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Connectivity01';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
my $name = name( $zone );
|
||||
my @ns_list = @{ Zonemaster::Engine::TestMethods->method4and5( $zone ) };
|
||||
|
||||
my @ns_ipv4 = ();
|
||||
my @ns_ipv6 = ();
|
||||
foreach my $ns ( @ns_list ) {
|
||||
if ( $ns->address->version == $IP_VERSION_4 and not Zonemaster::Engine::Profile->effective->get(q{net.ipv4}) ) {
|
||||
push @ns_ipv4, $ns;
|
||||
}
|
||||
elsif ( $ns->address->version == $IP_VERSION_6 and not Zonemaster::Engine::Profile->effective->get(q{net.ipv6}) ) {
|
||||
push @ns_ipv6, $ns;
|
||||
}
|
||||
}
|
||||
if ( @ns_ipv4 ) {
|
||||
push @results, _emit_log( "CN01_IPV4_DISABLED" => { ns_list => join( ';', @ns_ipv4 ) } );
|
||||
}
|
||||
if ( @ns_ipv6 ) {
|
||||
push @results, _emit_log( "CN01_IPV6_DISABLED" => { ns_list => join( ';', @ns_ipv6 ) } );
|
||||
}
|
||||
|
||||
_connectivity_loop("connectivity01", $name, \@ns_list, \@results);
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub connectivity01
|
||||
|
||||
=over
|
||||
|
||||
=item connectivity02()
|
||||
|
||||
my @logentry_array = connectivity02( $zone );
|
||||
|
||||
Runs the L<Connectivity02 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Connectivity-TP/connectivity02.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub connectivity02 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Connectivity02';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
my $name = name( $zone );
|
||||
my @ns_list = @{ Zonemaster::Engine::TestMethods->method4and5( $zone ) };
|
||||
|
||||
_connectivity_loop("connectivity02", $name, \@ns_list, \@results);
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub connectivity02
|
||||
|
||||
=over
|
||||
|
||||
=item connectivity03()
|
||||
|
||||
my @logentry_array = connectivity03( $zone );
|
||||
|
||||
Runs the L<Connectivity03 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Connectivity-TP/connectivity03.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub connectivity03 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Connectivity03';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
|
||||
my %ips = ( $IP_VERSION_4 => {}, $IP_VERSION_6 => {} );
|
||||
|
||||
foreach my $ns ( @{ Zonemaster::Engine::TestMethods->method4and5( $zone ) } ) {
|
||||
my $addr = $ns->address;
|
||||
$ips{ $addr->version }{ $addr->ip } = $addr;
|
||||
}
|
||||
|
||||
my @v4ips = values %{ $ips{$IP_VERSION_4} };
|
||||
my @v6ips = values %{ $ips{$IP_VERSION_6} };
|
||||
|
||||
my @v4asns;
|
||||
my @v4asnsets;
|
||||
my @v6asns;
|
||||
my @v6asnsets;
|
||||
|
||||
foreach my $v4ip ( @v4ips ) {
|
||||
my ( $asnref, $prefix, $raw, $ret_code ) = Zonemaster::Engine::ASNLookup->get_with_prefix( $v4ip );
|
||||
if ( defined $ret_code and ( $ret_code eq q{ERROR_ASN_DATABASE} or $ret_code eq q{EMPTY_ASN_SET} ) ) {
|
||||
push @results, _emit_log( $ret_code => { ns_ip => $v4ip->short } );
|
||||
}
|
||||
else {
|
||||
if ( $raw ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
ASN_INFOS_RAW => {
|
||||
ns_ip => $v4ip->short,
|
||||
data => $raw,
|
||||
}
|
||||
);
|
||||
}
|
||||
if ( $asnref ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
ASN_INFOS_ANNOUNCE_BY => {
|
||||
ns_ip => $v4ip->short,
|
||||
asn => join( q{,}, sort @{$asnref} ),
|
||||
}
|
||||
);
|
||||
push @v4asns, @{$asnref};
|
||||
push @v4asnsets, join( q{,}, sort { $a <=> $b } @{$asnref} );
|
||||
}
|
||||
if ( $prefix ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
ASN_INFOS_ANNOUNCE_IN => {
|
||||
ns_ip => $v4ip->short,
|
||||
prefix => sprintf "%s/%d",
|
||||
$prefix->ip, $prefix->prefixlen,
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
} ## end foreach my $v4ip ( @v4ips )
|
||||
foreach my $v6ip ( @v6ips ) {
|
||||
my ( $asnref, $prefix, $raw, $ret_code ) = Zonemaster::Engine::ASNLookup->get_with_prefix( $v6ip );
|
||||
if ( defined $ret_code and ( $ret_code eq q{ERROR_ASN_DATABASE} or $ret_code eq q{EMPTY_ASN_SET} ) ) {
|
||||
push @results, _emit_log( $ret_code => { ns_ip => $v6ip->short } );
|
||||
}
|
||||
else {
|
||||
if ( $raw ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
ASN_INFOS_RAW => {
|
||||
ns_ip => $v6ip->short,
|
||||
data => $raw,
|
||||
}
|
||||
);
|
||||
}
|
||||
if ( $asnref ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
ASN_INFOS_ANNOUNCE_BY => {
|
||||
ns_ip => $v6ip->short,
|
||||
asn => join( q{,}, sort @{$asnref} ),
|
||||
}
|
||||
);
|
||||
push @v6asns, @{$asnref};
|
||||
push @v6asnsets, join( q{,}, sort { $a <=> $b } @{$asnref} );
|
||||
}
|
||||
if ( $prefix ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
ASN_INFOS_ANNOUNCE_IN => {
|
||||
ns_ip => $v6ip->short,
|
||||
prefix => sprintf "%s/%d",
|
||||
$prefix->short, $prefix->prefixlen,
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
} ## end foreach my $v6ip ( @v6ips )
|
||||
|
||||
@v4asns = uniq sort { $a <=> $b } @v4asns;
|
||||
@v4asnsets = uniq sort @v4asnsets;
|
||||
@v6asns = uniq sort { $a <=> $b } @v6asns;
|
||||
@v6asnsets = uniq sort @v6asnsets;
|
||||
|
||||
if ( scalar @v4asns ) {
|
||||
if ( @v4asns == 1 ) {
|
||||
push @results, _emit_log( IPV4_ONE_ASN => { asn => $v4asns[0] } );
|
||||
}
|
||||
elsif ( @v4asnsets == 1 ) {
|
||||
push @results, _emit_log( IPV4_SAME_ASN => { asn_list => $v4asnsets[0] } );
|
||||
}
|
||||
else {
|
||||
push @results, _emit_log( IPV4_DIFFERENT_ASN => { asn_list => join( q{,}, @v4asns ) } );
|
||||
}
|
||||
}
|
||||
|
||||
if ( scalar @v6asns ) {
|
||||
if ( @v6asns == 1 ) {
|
||||
push @results, _emit_log( IPV6_ONE_ASN => { asn => $v6asns[0] } );
|
||||
}
|
||||
elsif ( @v6asnsets == 1 ) {
|
||||
push @results, _emit_log( IPV6_SAME_ASN => { asn_list => $v6asnsets[0] } );
|
||||
}
|
||||
else {
|
||||
push @results, _emit_log( IPV6_DIFFERENT_ASN => { asn_list => join( q{,}, @v6asns ) } );
|
||||
}
|
||||
}
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub connectivity03
|
||||
|
||||
=over
|
||||
|
||||
=item connectivity04()
|
||||
|
||||
my @logentry_array = connectivity04( $zone );
|
||||
|
||||
Runs the L<Connectivity04 Test Case|https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/Connectivity-TP/connectivity04.md>.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns a list of L<Zonemaster::Engine::Logger::Entry> objects.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub connectivity04 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
local $Zonemaster::Engine::Logger::TEST_CASE_NAME = 'Connectivity04';
|
||||
push my @results, _emit_log( TEST_CASE_START => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } );
|
||||
|
||||
my %prefixes;
|
||||
my %ip_already_processed;
|
||||
|
||||
my @nss = grep { $_->isa('Zonemaster::Engine::Nameserver') } (
|
||||
@{ Zonemaster::Engine::TestMethodsV2->get_del_ns_names_and_ips( $zone ) // [] },
|
||||
@{ Zonemaster::Engine::TestMethodsV2->get_zone_ns_names_and_ips( $zone ) // [] }
|
||||
);
|
||||
|
||||
foreach my $ns ( @nss ) {
|
||||
my $ip = $ns->address;
|
||||
|
||||
next if exists $ip_already_processed{$ip->version}{$ip->short};
|
||||
$ip_already_processed{$ip->version}{$ip->short} = 1;
|
||||
|
||||
my ( $asnref, $prefix, $raw, $ret_code ) = Zonemaster::Engine::ASNLookup->get_with_prefix( $ip );
|
||||
|
||||
if ( defined $ret_code and ( $ret_code eq q{ERROR_ASN_DATABASE} or $ret_code eq q{EMPTY_ASN_SET} ) ) {
|
||||
if ( $ret_code eq 'ERROR_ASN_DATABASE' ) {
|
||||
$ret_code = 'CN04_ERROR_PREFIX_DATABASE';
|
||||
}
|
||||
elsif ( $ret_code eq 'EMPTY_ASN_SET' ) {
|
||||
$ret_code = 'CN04_EMPTY_PREFIX_SET';
|
||||
}
|
||||
|
||||
push @results, _emit_log( $ret_code => { ns_ip => $ip->short } );
|
||||
}
|
||||
else {
|
||||
if ( $raw ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
CN04_ASN_INFOS_RAW => {
|
||||
ns_ip => $ip->short,
|
||||
data => $raw,
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
if ( $prefix ) {
|
||||
my $prefix_str;
|
||||
|
||||
if ( $prefix->version == 4 ) {
|
||||
$prefix_str = $prefix->prefix;
|
||||
}
|
||||
elsif ( $prefix->version == 6 ) {
|
||||
$prefix_str = $prefix->short . '/' . $prefix->prefixlen;
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
|
||||
push @results,
|
||||
_emit_log(
|
||||
CN04_ASN_INFOS_ANNOUNCE_IN => {
|
||||
ns_ip => $ip->short,
|
||||
prefix => sprintf "%s", $prefix_str,
|
||||
}
|
||||
);
|
||||
|
||||
push @{ $prefixes{$prefix->version}{$prefix_str} }, $ns;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ip_version ( sort keys %prefixes ) {
|
||||
my @combined_ns;
|
||||
|
||||
foreach my $prefix ( keys %{ $prefixes{$ip_version} } ) {
|
||||
if ( scalar @{ $prefixes{$ip_version}{$prefix} } == 1 ) {
|
||||
push @combined_ns, @{ $prefixes{$ip_version}{$prefix} };
|
||||
}
|
||||
elsif ( scalar @{ $prefixes{$ip_version}{$prefix} } >= 2 ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
"CN04_IPV${ip_version}_SAME_PREFIX" => {
|
||||
ip_prefix => $prefix,
|
||||
ns_list => join( q{;}, sort @{ $prefixes{$ip_version}{$prefix} } )
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
if ( scalar @combined_ns ) {
|
||||
push @results,
|
||||
_emit_log(
|
||||
"CN04_IPV${ip_version}_DIFFERENT_PREFIX" => {
|
||||
ns_list => join( q{;}, uniq sort @combined_ns )
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
push @results, _emit_log( "CN04_IPV${ip_version}_SINGLE_PREFIX" => {} ) if scalar keys %{ $prefixes{$ip_version} } == 1
|
||||
and scalar @{ (values %{ $prefixes{$ip_version} })[0] } == scalar keys %{ $ip_already_processed{$ip_version} };
|
||||
}
|
||||
|
||||
return ( @results, _emit_log( TEST_CASE_END => { testcase => $Zonemaster::Engine::Logger::TEST_CASE_NAME } ) );
|
||||
} ## end sub connectivity04
|
||||
|
||||
1;
|
||||
1044
zonemaster-engine/lib/Zonemaster/Engine/Test/Consistency.pm
Normal file
1044
zonemaster-engine/lib/Zonemaster/Engine/Test/Consistency.pm
Normal file
File diff suppressed because it is too large
Load Diff
5558
zonemaster-engine/lib/Zonemaster/Engine/Test/DNSSEC.pm
Normal file
5558
zonemaster-engine/lib/Zonemaster/Engine/Test/DNSSEC.pm
Normal file
File diff suppressed because it is too large
Load Diff
1106
zonemaster-engine/lib/Zonemaster/Engine/Test/Delegation.pm
Normal file
1106
zonemaster-engine/lib/Zonemaster/Engine/Test/Delegation.pm
Normal file
File diff suppressed because it is too large
Load Diff
1808
zonemaster-engine/lib/Zonemaster/Engine/Test/Nameserver.pm
Normal file
1808
zonemaster-engine/lib/Zonemaster/Engine/Test/Nameserver.pm
Normal file
File diff suppressed because it is too large
Load Diff
1134
zonemaster-engine/lib/Zonemaster/Engine/Test/Syntax.pm
Normal file
1134
zonemaster-engine/lib/Zonemaster/Engine/Test/Syntax.pm
Normal file
File diff suppressed because it is too large
Load Diff
1632
zonemaster-engine/lib/Zonemaster/Engine/Test/Zone.pm
Normal file
1632
zonemaster-engine/lib/Zonemaster/Engine/Test/Zone.pm
Normal file
File diff suppressed because it is too large
Load Diff
115
zonemaster-engine/lib/Zonemaster/Engine/TestMethods.pm
Normal file
115
zonemaster-engine/lib/Zonemaster/Engine/TestMethods.pm
Normal file
@@ -0,0 +1,115 @@
|
||||
package Zonemaster::Engine::TestMethods;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.3");
|
||||
|
||||
use List::MoreUtils qw[uniq];
|
||||
use Zonemaster::Engine::Util;
|
||||
|
||||
sub method1 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
return $zone->parent;
|
||||
}
|
||||
|
||||
sub method2 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
return $zone->glue_names;
|
||||
}
|
||||
|
||||
sub method3 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my @child_nsnames;
|
||||
my @nsnames;
|
||||
my $ns_aref = $zone->query_all( $zone->name, q{NS} );
|
||||
foreach my $p ( @{$ns_aref} ) {
|
||||
next if not $p;
|
||||
push @nsnames, $p->get_records_for_name( q{NS}, $zone->name );
|
||||
}
|
||||
@child_nsnames = uniq map { name( lc( $_->nsdname ) ) } @nsnames;
|
||||
|
||||
return [@child_nsnames];
|
||||
}
|
||||
|
||||
sub method4 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
return $zone->glue;
|
||||
}
|
||||
|
||||
sub method5 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
return $zone->ns;
|
||||
}
|
||||
|
||||
sub method2and3 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my %union = map { $_->string => $_ } @{ $class->method2( $zone ) }, @{ $class->method3( $zone ) };
|
||||
return [ @union{ sort keys %union } ];
|
||||
}
|
||||
|
||||
sub method4and5 {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my %union = map { $_->string => $_ } @{ $class->method4( $zone ) }, @{ $class->method5( $zone ) };
|
||||
return [ @union{ sort keys %union } ];
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::TestMethods - Methods common to Test Specification used in test modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @results = Zonemaster::Engine::TestMethods->method1($zone);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
For details on what these methods implement, see the test
|
||||
specification documents.
|
||||
|
||||
=over
|
||||
|
||||
=item method1($zone)
|
||||
|
||||
Returns either a Zonemaster::Engine::Zone or undef.
|
||||
|
||||
=item method2($zone)
|
||||
|
||||
Returns an arrayref of Zonemaster::Engine::DNSName objects.
|
||||
|
||||
=item method3($zone)
|
||||
|
||||
Returns an arrayref of Zonemaster::Engine::DNSName objects.
|
||||
|
||||
=item method4($zone)
|
||||
|
||||
Returns something that behaves like an arrayref of Zonemaster::Engine::Nameserver objects.
|
||||
|
||||
=item method5($zone)
|
||||
|
||||
Returns something that behaves like an arrayref of Zonemaster::Engine::Nameserver objects.
|
||||
|
||||
=item method2and3($zone)
|
||||
|
||||
Returns the union of Zonemaster::Engine::DNSName objects returned by
|
||||
method2($zone) and method3($zone) in a arrayref.
|
||||
The elements are sorted according to their string representation.
|
||||
|
||||
=item method4and5($zone)
|
||||
|
||||
Returns the union of Zonemaster::Engine::Nameserver objects returned by
|
||||
method4($zone) and method5($zone) in a arrayref.
|
||||
The elements are sorted according to their string representation.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
836
zonemaster-engine/lib/Zonemaster/Engine/TestMethodsV2.pm
Normal file
836
zonemaster-engine/lib/Zonemaster/Engine/TestMethodsV2.pm
Normal file
@@ -0,0 +1,836 @@
|
||||
package Zonemaster::Engine::TestMethodsV2;
|
||||
|
||||
use v5.26.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.0");
|
||||
|
||||
use Carp;
|
||||
use List::MoreUtils qw[uniq];
|
||||
use Memoize;
|
||||
|
||||
use Zonemaster::Engine::Util;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::TestMethodsV2 - Version 2 of Methods common to Test Specifications used in Test modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @results = Zonemaster::Engine::TestMethodsV2->get_parent_ns_ips($zone);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
For details on what these Methods implement, see the Test Specifications document
|
||||
(https://github.com/zonemaster/zonemaster/blob/master/docs/public/specifications/tests/MethodsV2.md).
|
||||
|
||||
=over
|
||||
|
||||
=item get_parent_ns_names_and_ips($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method obtains the name server names and IP addresses that serve the parent zone, i.e. the zone from which the Child Zone is delegated.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an empty arrayref if C<$zone> is the root zone or if an undelegated test is in progress. Else, returns an arrayref of L<Zonemaster::Engine::Nameserver> objects, or C<undef> if no parent zone was found.
|
||||
|
||||
The result of this Method is cached for performance reasons. This cache can be invalidated by calling C<clear_cache()> if necessary.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_parent_ns_names_and_ips {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $is_undelegated = Zonemaster::Engine::Recursor->has_fake_addresses( $zone->name->string );
|
||||
|
||||
if ( $zone->name->string eq "." or $is_undelegated ) {
|
||||
return [];
|
||||
}
|
||||
|
||||
my %handled_servers;
|
||||
my @parent_ns;
|
||||
|
||||
my %rrs_ns;
|
||||
my $type_soa = q{SOA};
|
||||
my $type_ns = q{NS};
|
||||
|
||||
my %remaining_servers = ( '.' => [ Zonemaster::Engine::Recursor->root_servers ] );
|
||||
|
||||
my sub push_to_remaining_servers {
|
||||
my ( $ns, $zone_name ) = @_;
|
||||
|
||||
unless ( exists $handled_servers{$zone_name}{"$ns"} ) {
|
||||
unless ( grep { $_ eq $ns } @{ $remaining_servers{$zone_name} } ) {
|
||||
push @{ $remaining_servers{$zone_name} }, $ns;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
while ( my $zone_name = ( sort keys %remaining_servers )[0] ) {
|
||||
CUR_SERVERS:
|
||||
while ( my $ns = shift @{ $remaining_servers{$zone_name} } ) {
|
||||
my $addr = $ns->address->short;
|
||||
if ( exists $handled_servers{$zone_name}{"$ns"} ) {
|
||||
push @parent_ns, $ns if ( grep { $_->address->short eq $addr and $_ ne $ns } @parent_ns );
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
$handled_servers{$zone_name}{"$ns"} = 1;
|
||||
|
||||
if ( ( $ns->address->version == 4 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) )
|
||||
or ( $ns->address->version == 6 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) ) {
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
|
||||
my $p_soa = $ns->query( $zone_name, $type_soa );
|
||||
|
||||
unless ( $p_soa and $p_soa->rcode eq 'NOERROR' and $p_soa->aa and scalar $p_soa->get_records_for_name( $type_soa, $zone_name, 'answer' ) == 1 ) {
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
|
||||
my $p_ns = $ns->query( $zone_name, $type_ns );
|
||||
|
||||
unless ( $p_ns and $p_ns->rcode eq 'NOERROR' and $p_ns->aa and scalar $p_ns->get_records( $type_ns, 'answer' ) > 0
|
||||
and scalar $p_ns->get_records( $type_ns, 'answer' ) == scalar $p_ns->get_records_for_name( $type_ns, $zone_name, 'answer' )
|
||||
) {
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
|
||||
%rrs_ns = map { name( $_->nsdname )->string => [] } $p_ns->get_records_for_name( $type_ns, $zone_name, 'answer' );
|
||||
|
||||
foreach my $rr ( $p_ns->get_records( 'A', 'additional' ), $p_ns->get_records( 'AAAA', 'additional' ) ) {
|
||||
if ( exists $rrs_ns{name( $rr->owner )->string} ) {
|
||||
push @{ $rrs_ns{name( $rr->owner )->string} }, $rr->address;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns_name ( keys %rrs_ns ) {
|
||||
unless ( scalar @{ $rrs_ns{$ns_name} } ) {
|
||||
for my $qtype ( q{A}, q{AAAA} ) {
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ns_name, $qtype );
|
||||
|
||||
if ( $p and $p->rcode eq 'NOERROR' ) {
|
||||
push @{ $rrs_ns{$ns_name} }, $_->address for $p->get_records_for_name( $qtype, $ns_name );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns_ip ( @{ $rrs_ns{$ns_name} } ) {
|
||||
push_to_remaining_servers ns( $ns_name, $ns_ip ), $zone_name;
|
||||
}
|
||||
}
|
||||
|
||||
my $intermediate_query_name = name( $zone_name );
|
||||
my $loop_zone_name = $zone_name;
|
||||
my $loop_counter = 0;
|
||||
|
||||
LOOP:
|
||||
while() {
|
||||
$loop_counter += 1;
|
||||
if ( $loop_counter >= 1000 ) {
|
||||
Zonemaster::Engine->logger->add( LOOP_PROTECTION => {
|
||||
caller => 'Zonemaster::Engine::TestMethodsV2->get_parent_ns_ips',
|
||||
child_zone_name => $zone->name,
|
||||
name => $loop_zone_name,
|
||||
intermediate_query_name => $intermediate_query_name
|
||||
}
|
||||
);
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
last if scalar @{ $intermediate_query_name->labels } >= scalar @{ $zone->name->labels };
|
||||
$intermediate_query_name = name( @{ $zone->name->labels }[ ( scalar @{ $zone->name->labels } - scalar @{ $intermediate_query_name->labels } ) - 1 ] . '.' . $intermediate_query_name->string );
|
||||
|
||||
$p_soa = $ns->query( $intermediate_query_name, $type_soa );
|
||||
|
||||
unless ( $p_soa ) {
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
|
||||
if ( $p_soa->rcode eq 'NOERROR' and $p_soa->aa and scalar $p_soa->get_records_for_name( $type_soa, $intermediate_query_name, 'answer' ) == 1 ) {
|
||||
if ( $intermediate_query_name->string eq $zone->name->string ) {
|
||||
push @parent_ns, $ns;
|
||||
}
|
||||
else {
|
||||
$p_ns = $ns->query( $intermediate_query_name, $type_ns );
|
||||
|
||||
unless ( $p_ns and $p_ns->rcode eq 'NOERROR' and $p_ns->aa and scalar $p_ns->get_records( $type_ns, 'answer' ) > 0
|
||||
and scalar $p_ns->get_records( $type_ns, 'answer' ) == scalar $p_ns->get_records_for_name( $type_ns, $intermediate_query_name, 'answer' )
|
||||
) {
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
|
||||
my %rrs_ns_bis = map { name( $_->nsdname )->string => [] } $p_ns->get_records_for_name( $type_ns, $intermediate_query_name, 'answer' );
|
||||
|
||||
foreach my $rr ( $p_ns->get_records( 'A', 'additional' ), $p_ns->get_records( 'AAAA', 'additional' ) ) {
|
||||
if ( exists $rrs_ns_bis{name( $rr->owner )->string} ) {
|
||||
push @{ $rrs_ns_bis{name( $rr->owner )->string} }, $rr->address;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns_name ( keys %rrs_ns_bis ) {
|
||||
unless ( scalar @{ $rrs_ns_bis{$ns_name} } > 0 ) {
|
||||
for my $qtype ( q{A}, q{AAAA} ) {
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ns_name, $qtype );
|
||||
|
||||
if ( $p and $p->rcode eq 'NOERROR' ) {
|
||||
push @{ $rrs_ns_bis{$ns_name} }, $_->address for $p->get_records_for_name( $qtype, $ns_name );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns_ip ( @{ $rrs_ns_bis{$ns_name} } ) {
|
||||
push_to_remaining_servers ns( $ns_name, $ns_ip ), $intermediate_query_name;
|
||||
}
|
||||
}
|
||||
|
||||
$loop_zone_name = $intermediate_query_name->string;
|
||||
next LOOP;
|
||||
}
|
||||
}
|
||||
elsif ( $p_soa->is_redirect and scalar $p_soa->get_records_for_name( $type_ns, $intermediate_query_name, 'authority' ) ) {
|
||||
if ( $intermediate_query_name->string eq $zone->name->string ) {
|
||||
push @parent_ns, $ns;
|
||||
}
|
||||
else {
|
||||
my %rrs_ns_bis = map { name( $_->nsdname )->string => [] } $p_soa->get_records_for_name( $type_ns, $intermediate_query_name, 'authority' );
|
||||
|
||||
foreach my $rr ( $p_soa->get_records( 'A', 'additional' ), $p_soa->get_records( 'AAAA', 'additional' ) ) {
|
||||
if ( exists $rrs_ns_bis{name( $rr->owner )->string} ) {
|
||||
push @{ $rrs_ns_bis{name( $rr->owner )->string} }, $rr->address;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns_name ( keys %rrs_ns_bis ) {
|
||||
unless ( scalar @{ $rrs_ns_bis{$ns_name} } > 0 ) {
|
||||
for my $qtype ( q{A}, q{AAAA} ) {
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ns_name, $qtype );
|
||||
|
||||
if ( $p and $p->rcode eq 'NOERROR' ) {
|
||||
push @{ $rrs_ns_bis{$ns_name} }, $_->address for $p->get_records_for_name( $qtype, $ns_name );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $ns_ip ( @{ $rrs_ns_bis{$ns_name} } ) {
|
||||
push_to_remaining_servers ns( $ns_name, $ns_ip ), $intermediate_query_name;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $p_soa->rcode eq 'NOERROR' and $p_soa->aa ) {
|
||||
next LOOP if $intermediate_query_name->string ne $zone->name->string;
|
||||
}
|
||||
|
||||
next CUR_SERVERS;
|
||||
}
|
||||
}
|
||||
|
||||
delete $remaining_servers{$zone_name};
|
||||
}
|
||||
|
||||
if ( scalar @parent_ns ) {
|
||||
return [ uniq sort @parent_ns ]
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# Memoize get_parent_ns_names_and_ips() because it is expensive and gets called a few
|
||||
# times with identical parameters.
|
||||
|
||||
memoize('get_parent_ns_names_and_ips',
|
||||
NORMALIZER => sub {
|
||||
my ( $class, $zone ) = @_;
|
||||
join "\034", ( $class, $zone->name );
|
||||
});
|
||||
|
||||
=over
|
||||
|
||||
=item get_parent_ns_ips($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method obtains the name servers that serve the parent zone, i.e. the zone from which the Child Zone is delegated. If more than one name server share the same IP address, only one among them is kept.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an empty arrayref if C<$zone> is the root zone or if an undelegated test is in progress. Else, returns an arrayref of L<Zonemaster::Engine::Nameserver> objects, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_parent_ns_ips {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
# FIXME: We really should just be outputting name server IPs here, as the
|
||||
# specification says. Instead we output name server objects (but filtered
|
||||
# on unique IP addresses) because these objects are required to perform
|
||||
# queries.
|
||||
|
||||
my $nameservers = $class->get_parent_ns_names_and_ips( $zone );
|
||||
|
||||
return undef unless defined $nameservers;
|
||||
|
||||
my %ns_by_ip = ();
|
||||
foreach my $ns ( @$nameservers ) {
|
||||
my $ip = $ns->address->short;
|
||||
$ns_by_ip{$ip} = $ns unless exists $ns_by_ip{$ip};
|
||||
}
|
||||
|
||||
return [ sort values %ns_by_ip ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item _get_oob_ips($zone, $ns_names_ref)
|
||||
|
||||
[Internal]
|
||||
|
||||
This Method will obtain the IP addresses of the Out-Of-Bailiwick name servers for the given zone and a given set of name server names.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object and an arrayref of L<Zonemaster::Engine::Nameserver> objects.
|
||||
|
||||
Returns an arrayref of L<Zonemaster::Engine::Nameserver> objects for each name server name that was successfully resolved to an IP address,
|
||||
and L<Zonemaster::Engine::DNSName> objects for each name server name that could not be resolved to an IP address.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _get_oob_ips {
|
||||
my ( $class, $zone, $ns_names_ref ) = @_;
|
||||
|
||||
unless ( defined $ns_names_ref and scalar @{ $ns_names_ref } ) {
|
||||
return [];
|
||||
}
|
||||
|
||||
my $is_undelegated = Zonemaster::Engine::Recursor->has_fake_addresses( $zone->name->string );
|
||||
my @oob_ns;
|
||||
my $found_ip;
|
||||
|
||||
for my $ns_name ( @{ $ns_names_ref } ) {
|
||||
$found_ip = 0;
|
||||
|
||||
unless ( $zone->name->is_in_bailiwick( $ns_name ) ) {
|
||||
if ( $is_undelegated and scalar Zonemaster::Engine::Recursor->get_fake_addresses( $zone->name->string, $ns_name->string ) ) {
|
||||
for my $ip ( Zonemaster::Engine::Recursor->get_fake_addresses( $zone->name->string, $ns_name->string ) ) {
|
||||
push @oob_ns, ns( $ns_name->string, $ip );
|
||||
$found_ip = 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
for my $qtype ( q{A}, q{AAAA} ) {
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ns_name, $qtype );
|
||||
|
||||
if ( $p and $p->rcode eq q{NOERROR} ) {
|
||||
if ( $p->has_rrs_of_type_for_name( q{CNAME}, $ns_name, q{answer} ) ) {
|
||||
my %cnames = map { name( $_->owner ) => name( $_->cname ) } $p->get_records( q{CNAME}, q{answer} );
|
||||
my $target = $ns_name;
|
||||
$target = $cnames{$target} while $cnames{$target};
|
||||
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $target ) ) {
|
||||
push @oob_ns, ns( $ns_name, $rr->address );
|
||||
$found_ip = 1;
|
||||
}
|
||||
}
|
||||
# CNAME was followed in a new recursive query
|
||||
elsif ( name( ($p->question)[0]->owner ) ne $ns_name and grep { $_->tag eq 'CNAME_FOLLOWED_OUT_OF_ZONE' and grep /^$ns_name$/, values %{ $_->args } } @{ Zonemaster::Engine->logger->entries } ) {
|
||||
my $cname_ns_name = name( ($p->question)[0]->owner );
|
||||
my $target = $cname_ns_name;
|
||||
|
||||
if ( $p->has_rrs_of_type_for_name( q{CNAME}, $cname_ns_name, q{answer} ) ) {
|
||||
my %cnames = map { name( $_->owner ) => name( $_->cname ) } $p->get_records( q{CNAME}, q{answer} );
|
||||
$target = $cnames{$target} while $cnames{$target};
|
||||
}
|
||||
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $target ) ) {
|
||||
push @oob_ns, ns( $ns_name, $rr->address );
|
||||
$found_ip = 1;
|
||||
}
|
||||
}
|
||||
elsif ( $p->has_rrs_of_type_for_name( $qtype, $ns_name ) ) {
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $ns_name ) ) {
|
||||
push @oob_ns, ns( $ns_name, $rr->address );
|
||||
$found_ip = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
push @oob_ns, $ns_name unless $found_ip;
|
||||
}
|
||||
}
|
||||
|
||||
return [ uniq sort @oob_ns ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item _get_delegation($zone)
|
||||
|
||||
[Internal]
|
||||
|
||||
This Method will obtain the name server names (from the NS records) and the IP addresses (from Glue records) from the delegation of the given zone from the parent zone.
|
||||
Glue Records are address records for In-Bailiwick name server names, if any.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of L<Zonemaster::Engine::Nameserver> objects, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _get_delegation {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $is_undelegated = Zonemaster::Engine::Recursor->has_fake_addresses( $zone->name->string );
|
||||
my %delegation_ns;
|
||||
my %aa_ns;
|
||||
my @ib_ns;
|
||||
|
||||
if ( $is_undelegated ) {
|
||||
for my $ns_name ( Zonemaster::Engine::Recursor->get_fake_names( $zone->name->string ) ) {
|
||||
if ( $zone->name->is_in_bailiwick( name( $ns_name ) ) ) {
|
||||
for my $ns_ip ( Zonemaster::Engine::Recursor->get_fake_addresses( $zone->name->string, $ns_name ) ){
|
||||
push @ib_ns, ns( $ns_name, $ns_ip);
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @ib_ns, name( $ns_name );
|
||||
}
|
||||
}
|
||||
|
||||
return [ uniq sort @ib_ns ];
|
||||
}
|
||||
elsif ( $zone->name->string eq '.' ) {
|
||||
return [ uniq sort Zonemaster::Engine::Recursor->root_servers() ];
|
||||
}
|
||||
else {
|
||||
my $parent_ref = $class->get_parent_ns_ips( $zone );
|
||||
|
||||
return undef unless defined $parent_ref;
|
||||
|
||||
for my $ns ( @{ $parent_ref } ) {
|
||||
my $p = $ns->query( $zone->name, q{NS} );
|
||||
|
||||
if ( $p and $p->rcode eq q{NOERROR} ) {
|
||||
if ( $p->is_redirect ){
|
||||
for my $rr ( $p->get_records_for_name( q{NS}, $zone->name->string, q{authority} ) ) {
|
||||
$delegation_ns{$rr->nsdname} = [] unless exists $delegation_ns{$rr->nsdname};
|
||||
}
|
||||
|
||||
for my $rr ( $p->get_records( q{A}, q{additional} ), $p->get_records( q{AAAA}, q{additional} ) ) {
|
||||
if ( $zone->name->is_in_bailiwick( name( $rr->owner ) ) and scalar grep { $_ eq $rr->owner } keys %delegation_ns ) {
|
||||
push @{ $delegation_ns{$rr->owner} }, $rr->address;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $p->aa and scalar $p->get_records_for_name( q{NS}, $zone->name->string, q{answer} ) ) {
|
||||
for my $rr ( $p->get_records_for_name( q{NS}, $zone->name->string, q{answer} ) ) {
|
||||
$aa_ns{$rr->nsdname} = [] unless exists $aa_ns{$rr->nsdname};
|
||||
}
|
||||
|
||||
for my $rr ( $p->get_records( q{A}, q{additional} ), $p->get_records( q{AAAA}, q{additional} ) ) {
|
||||
if ( $zone->name->is_in_bailiwick( name( $rr->owner ) ) and scalar grep { $_ eq $rr->owner } keys %aa_ns ) {
|
||||
push @{ $aa_ns{$rr->owner} }, $rr->address;
|
||||
}
|
||||
}
|
||||
|
||||
for my $ns_name ( keys %aa_ns ) {
|
||||
unless ( scalar $aa_ns{$ns_name} ) {
|
||||
for my $qtype ( q{A}, q{AAAA} ) {
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ns_name, $qtype );
|
||||
|
||||
if ( $p and $p->rcode eq q{NOERROR} ) {
|
||||
if ( $p->has_rrs_of_type_for_name( q{CNAME}, $ns_name, q{answer} ) ) {
|
||||
my %cnames = map { name( $_->owner ) => name( $_->cname ) } $p->get_records( q{CNAME}, q{answer} );
|
||||
my $target = $ns_name;
|
||||
$target = $cnames{$target} while $cnames{$target};
|
||||
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $target ) ) {
|
||||
push @{ $aa_ns{$ns_name} }, $rr->address;
|
||||
}
|
||||
}
|
||||
# CNAME was followed in a new recursive query
|
||||
elsif ( name( ($p->question)[0]->owner ) ne $ns_name and grep { $_->tag eq 'CNAME_FOLLOWED_OUT_OF_ZONE' and grep /^$ns_name$/, values %{ $_->args } } @{ Zonemaster::Engine->logger->entries } ) {
|
||||
my $cname_ns_name = name( ($p->question)[0]->owner );
|
||||
my $target = $cname_ns_name;
|
||||
|
||||
if ( $p->has_rrs_of_type_for_name( q{CNAME}, $cname_ns_name, q{answer} ) ) {
|
||||
my %cnames = map { name( $_->owner ) => name( $_->cname ) } $p->get_records( q{CNAME}, q{answer} );
|
||||
$target = $cnames{$target} while $cnames{$target};
|
||||
}
|
||||
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $target ) ) {
|
||||
push @{ $aa_ns{$ns_name} }, $rr->address;
|
||||
}
|
||||
}
|
||||
elsif ( $p->has_rrs_of_type_for_name( $qtype, $ns_name ) ) {
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $ns_name ) ) {
|
||||
push @{ $aa_ns{$ns_name} }, $rr->address;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $hash_ref;
|
||||
if ( scalar keys %delegation_ns ) {
|
||||
$hash_ref = \%delegation_ns;
|
||||
}
|
||||
elsif ( scalar keys %aa_ns ) {
|
||||
$hash_ref = \%aa_ns;
|
||||
}
|
||||
else {
|
||||
return [];
|
||||
}
|
||||
|
||||
for my $ns_name ( keys %{ $hash_ref } ) {
|
||||
if ( scalar @{ %{ $hash_ref }{$ns_name} } ) {
|
||||
for my $ns_ip ( uniq @{ %{ $hash_ref }{$ns_name} } ) {
|
||||
push @ib_ns, ns( $ns_name, $ns_ip );
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @ib_ns, name( $ns_name );
|
||||
}
|
||||
}
|
||||
|
||||
return [ uniq sort @ib_ns ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item get_del_ns_names_and_ips($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method will obtain the name server names (from the NS records) and the IP addresses (from Glue Records) from the delegation of the given zone from the parent zone.
|
||||
Glue Records, if any, are address records for name server names. Also obtain the IP addresses for the Out-Of-Bailiwick name server names, if any.
|
||||
If the Glue Records include address records for Out-Of-Bailiwick name servers they will be included twice, unless identical.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of L<Zonemaster::Engine::Nameserver> objects for each name server name that was successfully resolved to an IP address,
|
||||
and L<Zonemaster::Engine::DNSName> objects for each name server name that could not be resolved to an IP address, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_del_ns_names_and_ips {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $ns_ref = $class->_get_delegation( $zone );
|
||||
|
||||
return undef unless defined $ns_ref;
|
||||
|
||||
my @ns_names = grep { $_->isa('Zonemaster::Engine::DNSName') } @{ $ns_ref };
|
||||
|
||||
my $oob_ns_ref = $class->_get_oob_ips( $zone, \@ns_names );
|
||||
|
||||
@{ $ns_ref } = grep { $_->isa('Zonemaster::Engine::Nameserver') } @{ $ns_ref };
|
||||
|
||||
return [ uniq sort (@{ $ns_ref }, @{ $oob_ns_ref }) ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item get_del_ns_names($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method will obtain the name server names of the given zone as defined in the delegation from parent zone.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of strings, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_del_ns_names {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $ns_ref = $class->get_del_ns_names_and_ips( $zone );
|
||||
|
||||
return undef unless defined $ns_ref;
|
||||
|
||||
return [ uniq sort map { $_->isa('Zonemaster::Engine::Nameserver') ? $_->name : $_ } @{ $ns_ref } ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item get_del_ns_ips($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method will obtain the IP addresses (from Glue Records) from the delegation of the given zone from the parent zone.
|
||||
Glue Records are address records for In-Bailiwick name server names, if any. Also obtain the IP addresses for the Out-Of-Bailiwick name server names, if any.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of strings, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_del_ns_ips {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $ns_ref = $class->get_del_ns_names_and_ips( $zone );
|
||||
|
||||
return undef unless defined $ns_ref;
|
||||
|
||||
return [ uniq sort map { $_->address->short } grep { $_->isa('Zonemaster::Engine::Nameserver') } @{ $ns_ref } ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item get_zone_ns_names($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method will obtain the names of the authoritative name servers for the given zone as defined in the NS records in the zone itself.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of strings, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_zone_ns_names {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
# 'get_del_ns_names_and_ips' instead of 'get_del_ns_ips', because we need Zonemaster::Engine::Nameserver objects to be able to do queries.
|
||||
my $ns_ref = $class->get_del_ns_names_and_ips( $zone );
|
||||
|
||||
return undef unless defined $ns_ref;
|
||||
|
||||
my @ns_names;
|
||||
|
||||
for my $ns ( @{ $ns_ref } ) {
|
||||
if ( $ns->isa('Zonemaster::Engine::Nameserver') ) {
|
||||
my $p = $ns->query( $zone->name, q{NS} );
|
||||
|
||||
if ( $p and $p->aa and $p->rcode eq q{NOERROR} ) {
|
||||
push @ns_names, $p->get_records_for_name( q{NS}, $zone->name->string, q{answer} );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return [ uniq sort map { name( lc( $_->nsdname ) ) } @ns_names ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item _get_ib_addr_in_zone($zone)
|
||||
|
||||
[Internal]
|
||||
|
||||
This Method will obtain the address records matching the In-Bailiwick name server names from the given zone.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of L<Zonemaster::Engine::Nameserver> objects, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _get_ib_addr_in_zone {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
# 'get_del_ns_names_and_ips' instead of 'get_del_ns_ips', because we need Zonemaster::Engine::Nameserver objects to be able to do queries.
|
||||
my $del_ips_ref = $class->get_del_ns_names_and_ips( $zone );
|
||||
my $ns_names_ref = $class->get_zone_ns_names( $zone );
|
||||
|
||||
return undef unless defined $del_ips_ref or defined $ns_names_ref or scalar @{ $del_ips_ref } or scalar @{ $ns_names_ref };
|
||||
|
||||
return [] unless scalar grep { $zone->name->is_in_bailiwick( $_ ) } @{ $ns_names_ref };
|
||||
|
||||
my %ib_ns;
|
||||
|
||||
for my $ns_name ( @{ $ns_names_ref } ) {
|
||||
if ( $zone->name->is_in_bailiwick( $ns_name ) ) {
|
||||
for my $ns ( @{ $del_ips_ref } ) {
|
||||
for my $qtype ( q{A}, q{AAAA} ) {
|
||||
my $p = Zonemaster::Engine::Recursor->recurse( $ns_name, $qtype, q{IN}, [ $ns ] );
|
||||
|
||||
if ( $p and $p->aa and $p->rcode eq q{NOERROR} ) {
|
||||
if ( $p->has_rrs_of_type_for_name( q{CNAME}, $ns_name, q{answer} ) ) {
|
||||
my %cnames = map { name( $_->owner ) => name( $_->cname ) } $p->get_records( q{CNAME}, q{answer} );
|
||||
my $target = $ns_name;
|
||||
$target = $cnames{$target} while $cnames{$target};
|
||||
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $target ) ) {
|
||||
push @{ $ib_ns{$ns_name} }, $rr->address;
|
||||
}
|
||||
}
|
||||
# CNAME was followed in a new recursive query
|
||||
elsif ( name( ($p->question)[0]->owner ) ne $ns_name and grep { $_->tag eq 'CNAME_FOLLOWED_OUT_OF_ZONE' and grep /^$ns_name$/, values %{ $_->args } } @{ Zonemaster::Engine->logger->entries } ) {
|
||||
my $cname_ns_name = name( ($p->question)[0]->owner );
|
||||
my $target = $cname_ns_name;
|
||||
|
||||
if ( $p->has_rrs_of_type_for_name( q{CNAME}, $cname_ns_name, q{answer} ) ) {
|
||||
my %cnames = map { name( $_->owner ) => name( $_->cname ) } $p->get_records( q{CNAME}, q{answer} );
|
||||
$target = $cnames{$target} while $cnames{$target};
|
||||
}
|
||||
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $target ) ) {
|
||||
push @{ $ib_ns{$ns_name} }, $rr->address;
|
||||
}
|
||||
}
|
||||
elsif ( $p->has_rrs_of_type_for_name( $qtype, $ns_name ) ) {
|
||||
for my $rr ( $p->get_records_for_name( $qtype, $ns_name ) ) {
|
||||
push @{ $ib_ns{$ns_name} }, $rr->address;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my @ib_ns_array;
|
||||
|
||||
for my $ns_name ( keys %ib_ns ) {
|
||||
for my $ns_ip ( uniq @{ $ib_ns{$ns_name} } ) {
|
||||
push @ib_ns_array, ns( $ns_name, $ns_ip );
|
||||
}
|
||||
}
|
||||
|
||||
return [ uniq sort @ib_ns_array ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item get_zone_ns_names_and_ips($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method will obtain the name server names (extracted from the NS records) from the apex of the given zone.
|
||||
For the In-Bailiwick name server names obtain the IP addresses from the given zone. For the Out-Of-Bailiwick name server names obtain the IP addresses from recursive lookup.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of L<Zonemaster::Engine::Nameserver> objects for each name server name that was successfully resolved to an IP address,
|
||||
and L<Zonemaster::Engine::DNSName> objects for each name server name that could not be resolved to an IP address, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_zone_ns_names_and_ips {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $ns_names_ref = $class->get_zone_ns_names( $zone );
|
||||
|
||||
return undef unless defined $ns_names_ref;
|
||||
|
||||
return [] unless scalar @{ $ns_names_ref };
|
||||
|
||||
my $ib_ns_ref = $class->_get_ib_addr_in_zone( $zone );
|
||||
my $oob_ns_ref = $class->_get_oob_ips( $zone, $ns_names_ref );
|
||||
|
||||
my @zone_ns;
|
||||
|
||||
for my $ns_name ( @{ $ns_names_ref } ) {
|
||||
if ( $zone->name->is_in_bailiwick( $ns_name ) ) {
|
||||
if ( $ib_ns_ref and scalar @{ $ib_ns_ref } ) {
|
||||
for my $ib_ns ( @{ $ib_ns_ref } ) {
|
||||
if ( $ns_name->string eq $ib_ns->name->string ) {
|
||||
push @zone_ns, ns( $ns_name, $ib_ns->address->short);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @zone_ns, $ns_name;
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ( $oob_ns_ref and scalar @{ $oob_ns_ref } ) {
|
||||
for my $oob_ns ( @{ $oob_ns_ref } ) {
|
||||
if ( $oob_ns->isa('Zonemaster::Engine::Nameserver') and $ns_name->string eq $oob_ns->name->string ) {
|
||||
push @zone_ns, ns( $ns_name, $oob_ns->address->short );
|
||||
}
|
||||
elsif ( $oob_ns->isa('Zonemaster::Engine::DNSName') and $ns_name->string eq $oob_ns->string ) {
|
||||
push @zone_ns, $ns_name;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @zone_ns, $ns_name;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return [ uniq sort @zone_ns ];
|
||||
}
|
||||
|
||||
=over
|
||||
|
||||
=item get_zone_ns_ips($zone)
|
||||
|
||||
[External]
|
||||
|
||||
This Method will obtain the IP addresses of the name servers, as extracted from the NS records of apex of the given zone.
|
||||
|
||||
Takes a L<Zonemaster::Engine::Zone> object.
|
||||
|
||||
Returns an arrayref of strings, or C<undef> if no parent zone was found.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_zone_ns_ips {
|
||||
my ( $class, $zone ) = @_;
|
||||
|
||||
my $ns_ref = $class->get_zone_ns_names_and_ips( $zone );
|
||||
|
||||
return undef unless defined $ns_ref;
|
||||
|
||||
my @ns_ips;
|
||||
foreach my $ns ( @{ $ns_ref } ) {
|
||||
push @ns_ips, $ns->address->short if $ns->isa('Zonemaster::Engine::Nameserver');
|
||||
}
|
||||
|
||||
return [ uniq sort @ns_ips ];
|
||||
}
|
||||
|
||||
|
||||
=over
|
||||
|
||||
=item clear_cache()
|
||||
|
||||
Clears previously cached results of the C<get_parent_ns_names_and_ips()> method.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub clear_cache() {
|
||||
Memoize::flush_cache(\&get_parent_ns_names_and_ips);
|
||||
}
|
||||
|
||||
1;
|
||||
429
zonemaster-engine/lib/Zonemaster/Engine/Translator.pm
Normal file
429
zonemaster-engine/lib/Zonemaster/Engine/Translator.pm
Normal file
@@ -0,0 +1,429 @@
|
||||
package Zonemaster::Engine::Translator;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.8");
|
||||
|
||||
use Carp qw[confess croak];
|
||||
use Locale::Messages qw[textdomain];
|
||||
use Locale::TextDomain qw[Zonemaster-Engine];
|
||||
use POSIX qw[setlocale LC_MESSAGES];
|
||||
use Readonly;
|
||||
|
||||
use Zonemaster::Engine::Test;
|
||||
|
||||
###
|
||||
### Tag descriptions
|
||||
###
|
||||
|
||||
Readonly my %TAG_DESCRIPTIONS => (
|
||||
CANNOT_CONTINUE => sub {
|
||||
__x # SYSTEM:CANNOT_CONTINUE
|
||||
"Not enough data about {domain} was found to be able to run tests.", @_;
|
||||
},
|
||||
DEPENDENCY_VERSION => sub {
|
||||
__x # SYSTEM:DEPENDENCY_VERSION
|
||||
"Using prerequisite module {name} version {version}.", @_;
|
||||
},
|
||||
GLOBAL_VERSION => sub {
|
||||
__x # SYSTEM:GLOBAL_VERSION
|
||||
"Using version {version} of the Zonemaster engine.", @_;
|
||||
},
|
||||
LOGGER_CALLBACK_ERROR => sub {
|
||||
__x # SYSTEM:LOGGER_CALLBACK_ERROR
|
||||
"Logger callback died with error: {exception}", @_;
|
||||
},
|
||||
LOOKUP_ERROR => sub {
|
||||
__x # SYSTEM:LOOKUP_ERROR
|
||||
"DNS query to {ns} for {domain}/{type}/{class} failed with error: {message}", @_;
|
||||
},
|
||||
MODULE_ERROR => sub {
|
||||
__x # SYSTEM:MODULE_ERROR
|
||||
"Fatal error in {module}: {msg}", @_;
|
||||
},
|
||||
MODULE_VERSION => sub {
|
||||
__x # SYSTEM:MODULE_VERSION
|
||||
"Using module {module} version {version}.", @_;
|
||||
},
|
||||
MODULE_END => sub {
|
||||
__x # SYSTEM:MODULE_END
|
||||
"Module {module} finished running.", @_;
|
||||
},
|
||||
NO_NETWORK => sub {
|
||||
__x # SYSTEM:NO_NETWORK
|
||||
"Both IPv4 and IPv6 are disabled.";
|
||||
},
|
||||
UNKNOWN_METHOD => sub {
|
||||
__x # SYSTEM:UNKNOWN_METHOD
|
||||
"Request to run unknown method {testcase} in module {module}.", @_;
|
||||
},
|
||||
UNKNOWN_MODULE => sub {
|
||||
__x # SYSTEM:UNKNOWN_MODULE
|
||||
"Request to run {testcase} in unknown module {module}. Known modules: {module_list}.", @_;
|
||||
},
|
||||
SKIP_IPV4_DISABLED => sub {
|
||||
__x # SYSTEM:SKIP_IPV4_DISABLED
|
||||
"IPv4 is disabled, not sending \"{rrtype}\" query to {ns}.", @_;
|
||||
},
|
||||
SKIP_IPV6_DISABLED => sub {
|
||||
__x # SYSTEM:SKIP_IPV6_DISABLED
|
||||
"IPv6 is disabled, not sending \"{rrtype}\" query to {ns}.", @_;
|
||||
},
|
||||
FAKE_DELEGATION_TO_SELF => sub {
|
||||
__x # SYSTEM:FAKE_DELEGATION_TO_SELF
|
||||
"Name server {ns} not adding fake delegation for domain {domain} to itself.", @_;
|
||||
},
|
||||
FAKE_DELEGATION_IN_ZONE_NO_IP => sub {
|
||||
__x # SYSTEM:FAKE_DELEGATION_IN_ZONE_NO_IP
|
||||
"The fake delegation of domain {domain} includes an in-zone name server {nsname} "
|
||||
. "without mandatory glue (without IP address).",
|
||||
@_;
|
||||
},
|
||||
FAKE_DELEGATION_NO_IP => sub {
|
||||
__x # SYSTEM:FAKE_DELEGATION_NO_IP
|
||||
"The fake delegation of domain {domain} includes a name server {nsname} "
|
||||
. "that cannot be resolved to any IP address.",
|
||||
@_;
|
||||
},
|
||||
PACKET_BIG => sub {
|
||||
__x # SYSTEM:PACKET_BIG
|
||||
"Big packet size ({size}) (try with \"{command}\").", @_;
|
||||
},
|
||||
);
|
||||
|
||||
###
|
||||
### Construction
|
||||
###
|
||||
|
||||
my $instance;
|
||||
|
||||
sub new {
|
||||
my ( $class, %attrs ) = @_;
|
||||
|
||||
$class->initialize( %attrs );
|
||||
|
||||
return $class->instance;
|
||||
}
|
||||
|
||||
sub instance {
|
||||
my ( $class ) = @_;
|
||||
|
||||
if ( !defined $instance ) {
|
||||
$class->initialize();
|
||||
}
|
||||
|
||||
return $instance;
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ( $class, %attrs ) = @_;
|
||||
|
||||
if ( defined $instance ) {
|
||||
confess "already initialized";
|
||||
}
|
||||
|
||||
my $locale;
|
||||
if ( exists $attrs{locale} ) {
|
||||
$locale = delete $attrs{locale};
|
||||
|
||||
if ( !defined $locale || ref $locale ne '' ) {
|
||||
confess "argument 'locale' must not be a defined scalar";
|
||||
}
|
||||
}
|
||||
|
||||
my $obj = {
|
||||
_locale => $locale // _init_locale(),
|
||||
_all_tag_descriptions => $class->_build_all_tag_descriptions(),
|
||||
_last_language => _build_last_language(),
|
||||
};
|
||||
|
||||
$instance = bless $obj, $class;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
###
|
||||
### Builder Methods
|
||||
###
|
||||
|
||||
# Get the program's underlying LC_MESSAGES and make sure it can be effectively
|
||||
# updated down the line.
|
||||
#
|
||||
# If the underlying LC_MESSAGES is invalid, it attempts to second guess Perl's
|
||||
# fallback locale.
|
||||
#
|
||||
# Side effects:
|
||||
# * Updates the program's underlying LC_MESSAGES to the returned value.
|
||||
# * Unsets LC_ALL.
|
||||
sub _init_locale {
|
||||
my $locale = setlocale( LC_MESSAGES, "" );
|
||||
|
||||
delete $ENV{LC_ALL};
|
||||
|
||||
if ( !defined $locale ) {
|
||||
my $language = $ENV{LANGUAGE} // "";
|
||||
for my $value ( split /:/, $language ) {
|
||||
if ( $value ne "" && $value !~ /[.]/ ) {
|
||||
$value .= ".UTF-8";
|
||||
}
|
||||
$locale = setlocale( LC_MESSAGES, $value );
|
||||
if ( defined $locale ) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
$locale //= "C";
|
||||
}
|
||||
|
||||
return $locale;
|
||||
}
|
||||
|
||||
sub _load_data {
|
||||
my $self = shift;
|
||||
|
||||
my $old_locale = $self->locale;
|
||||
|
||||
$self->locale( 'C' );
|
||||
|
||||
my %data;
|
||||
for my $mod ( keys %{ $self->all_tag_descriptions } ) {
|
||||
for my $tag ( keys %{ $self->all_tag_descriptions->{$mod} } ) {
|
||||
$data{$mod}{$tag} = $self->_translate_tag( $mod, $tag, {} );
|
||||
}
|
||||
}
|
||||
|
||||
$self->locale( $old_locale );
|
||||
|
||||
return \%data;
|
||||
}
|
||||
|
||||
sub _build_all_tag_descriptions {
|
||||
my ( $class ) = @_;
|
||||
|
||||
my %all_tag_descriptions;
|
||||
|
||||
$all_tag_descriptions{System} = \%TAG_DESCRIPTIONS;
|
||||
foreach my $mod ( Zonemaster::Engine::Test->modules ) {
|
||||
my $module = 'Zonemaster::Engine::Test::' . $mod;
|
||||
$all_tag_descriptions{ $mod } = $module->tag_descriptions;
|
||||
}
|
||||
|
||||
return \%all_tag_descriptions;
|
||||
}
|
||||
|
||||
sub _build_last_language {
|
||||
return $ENV{LANGUAGE} // '';
|
||||
}
|
||||
|
||||
###
|
||||
### Instance methods
|
||||
###
|
||||
|
||||
sub data {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_data} ) {
|
||||
$self->{_data} = $self->_load_data;
|
||||
}
|
||||
|
||||
return $self->{_data};
|
||||
}
|
||||
|
||||
sub all_tag_descriptions {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $self->{_all_tag_descriptions};
|
||||
}
|
||||
|
||||
sub locale {
|
||||
my ( $self, @args ) = @_;
|
||||
|
||||
if ( @args ) {
|
||||
my $new_locale = shift @args;
|
||||
|
||||
# On some systems gettext takes its locale from setlocale().
|
||||
if ( !defined setlocale( LC_MESSAGES, $new_locale ) ) {
|
||||
return;
|
||||
}
|
||||
|
||||
$self->_last_language( $ENV{LANGUAGE} // '' );
|
||||
|
||||
# On some systems gettext takes its locale from %ENV.
|
||||
$ENV{LC_MESSAGES} = $new_locale;
|
||||
|
||||
# On some systems gettext refuses to switch over to another locale unless
|
||||
# the textdomain is reset.
|
||||
textdomain( 'Zonemaster-Engine' );
|
||||
|
||||
if ( !defined $new_locale || ref $new_locale ne '' ) {
|
||||
croak "locale must be a defined scalar";
|
||||
}
|
||||
|
||||
$self->{_locale} = $new_locale;
|
||||
} ## end if ( @args )
|
||||
|
||||
return $self->{_locale};
|
||||
};
|
||||
|
||||
sub to_string {
|
||||
my ( $self, $entry ) = @_;
|
||||
|
||||
return sprintf( "%7.2f %-9s %s", $entry->timestamp, $entry->level, $self->translate_tag( $entry ) );
|
||||
}
|
||||
|
||||
sub translate_tag {
|
||||
my ( $self, $entry ) = @_;
|
||||
|
||||
return $self->_translate_tag( $entry->module, $entry->tag, $entry->printable_args ) // $entry->string;
|
||||
}
|
||||
|
||||
|
||||
sub test_case_description {
|
||||
my ( $self, $test_name ) = @_;
|
||||
|
||||
my $module = $test_name;
|
||||
$module =~ s/\d+$//;
|
||||
|
||||
return $self->_translate_tag( $module, uc $test_name, {} ) // $test_name;
|
||||
}
|
||||
|
||||
sub _last_language {
|
||||
my $self = shift;
|
||||
|
||||
if ( @_ ) {
|
||||
my $last_language = shift;
|
||||
if ( !defined $last_language || ref $last_language ne '' ) {
|
||||
croak "_last_language must be a defined scalar";
|
||||
}
|
||||
$self->{_last_language} = $last_language;
|
||||
}
|
||||
|
||||
return $self->{_last_language};
|
||||
}
|
||||
|
||||
sub _translate_tag {
|
||||
my ( $self, $module, $tag, $args ) = @_;
|
||||
|
||||
if ( $ENV{LANGUAGE} // '' ne $self->_last_language ) {
|
||||
$self->locale( $self->locale );
|
||||
}
|
||||
|
||||
my $code = $self->all_tag_descriptions->{$module}{$tag};
|
||||
|
||||
if ( $code ) {
|
||||
return $code->( %{$args} );
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Translator - translation support for Zonemaster
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Zonemaster::Engine::Translator->initialize( locale => 'sv_SE.UTF-8' );
|
||||
|
||||
my $trans = Zonemaster::Engine::Translator->instance;
|
||||
say $trans->to_string($entry);
|
||||
|
||||
This is a singleton class.
|
||||
|
||||
The instance of this class requires exclusive control over C<$ENV{LC_MESSAGES}>
|
||||
and the program's underlying LC_MESSAGES.
|
||||
At times it resets gettext's textdomain.
|
||||
On construction it unsets C<$ENV{LC_ALL}> and from then on it must remain unset.
|
||||
|
||||
On systems that support C<$ENV{LANGUAGE}>, this variable overrides the locale()
|
||||
attribute unless the locale() attribute is set to C<"C">.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item locale
|
||||
|
||||
The locale used for localized messages.
|
||||
|
||||
say $translator->locale();
|
||||
if ( !$translator->locale( 'sv_SE.UTF-8' ) ) {
|
||||
say "failed to update locale";
|
||||
}
|
||||
|
||||
The value of this attribute is mirrored in C<$ENV{LC_MESSAGES}>.
|
||||
|
||||
When writing to this attribute, a request is made to update the program's
|
||||
underlying LC_MESSAGES.
|
||||
If this request fails, the attribute value remains unchanged and an empty list
|
||||
is returned.
|
||||
|
||||
As a side effect when successfully updating this attribute gettext's textdomain
|
||||
is reset.
|
||||
|
||||
=item data
|
||||
|
||||
A reference to a hash with translation data. This is unlikely to be useful to
|
||||
end-users.
|
||||
|
||||
=item all_tag_descriptions
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item initialize(%args)
|
||||
|
||||
Provide initial values for the single instance of this class.
|
||||
|
||||
Zonemaster::Engine::Translator->initialize( locale => 'sv_SE.UTF-8' );
|
||||
|
||||
This method must be called at most once and before the first call to instance().
|
||||
|
||||
=item instance()
|
||||
|
||||
Returns the single instance of this class.
|
||||
|
||||
my $translator = Zonemaster::Engine::Translator->instance;
|
||||
|
||||
If initialize() has not been called prior to the first call to instance(), it
|
||||
is the same as if initialize() had been called without arguments.
|
||||
|
||||
=item new(%args)
|
||||
|
||||
Use of this method is deprecated.
|
||||
|
||||
=over
|
||||
|
||||
=item locale
|
||||
|
||||
If no initial value is provided to the constructor, one is determined by calling
|
||||
setlocale( LC_MESSAGES, "" ).
|
||||
|
||||
=back
|
||||
|
||||
=item to_string($entry)
|
||||
|
||||
Takes a L<Zonemaster::Engine::Logger::Entry> object as its argument and returns a translated string with the timestamp, level, message and arguments in the
|
||||
entry.
|
||||
|
||||
=item translate_tag($entry)
|
||||
|
||||
Takes a L<Zonemaster::Engine::Logger::Entry> object as its argument and returns a translation of its tag and arguments.
|
||||
|
||||
=item test_case_description($testcase)
|
||||
|
||||
Takes a string (test case ID) and returns the translated test case description.
|
||||
|
||||
=item BUILD
|
||||
|
||||
Internal method that's only mentioned here to placate L<Pod::Coverage>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
292
zonemaster-engine/lib/Zonemaster/Engine/Util.pm
Normal file
292
zonemaster-engine/lib/Zonemaster/Engine/Util.pm
Normal file
@@ -0,0 +1,292 @@
|
||||
package Zonemaster::Engine::Util;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.1.13");
|
||||
|
||||
use Exporter 'import';
|
||||
BEGIN {
|
||||
our @EXPORT_OK = qw[
|
||||
info
|
||||
ipversion_ok
|
||||
name
|
||||
ns
|
||||
parse_hints
|
||||
should_run_test
|
||||
scramble_case
|
||||
test_levels
|
||||
zone
|
||||
];
|
||||
our %EXPORT_TAGS = ( all => \@EXPORT_OK );
|
||||
|
||||
## no critic (Modules::ProhibitAutomaticExportation)
|
||||
our @EXPORT = qw[ ns info name scramble_case ];
|
||||
}
|
||||
|
||||
use Net::DNS::ZoneFile;
|
||||
use Pod::Simple::SimpleTree;
|
||||
|
||||
use Zonemaster::Engine;
|
||||
use Zonemaster::Engine::Constants qw[:ip :soa];
|
||||
use Zonemaster::Engine::DNSName;
|
||||
use Zonemaster::Engine::Profile;
|
||||
|
||||
sub ns {
|
||||
my ( $name, $address ) = @_;
|
||||
return Zonemaster::Engine::Nameserver->new( { name => $name, address => $address } );
|
||||
}
|
||||
|
||||
sub info {
|
||||
my ( $tag, $argref ) = @_;
|
||||
|
||||
return Zonemaster::Engine->logger->add( $tag, $argref );
|
||||
}
|
||||
|
||||
sub zone {
|
||||
my ( $name ) = @_;
|
||||
|
||||
return Zonemaster::Engine::Zone->new( { name => Zonemaster::Engine::DNSName->new( $name ) } );
|
||||
}
|
||||
|
||||
sub should_run_test {
|
||||
my ( $test_name ) = @_;
|
||||
my %test_names = map { $_ => 1 } @{ Zonemaster::Engine::Profile->effective->get( q{test_cases} ) };
|
||||
|
||||
return exists $test_names{$test_name};
|
||||
}
|
||||
|
||||
sub ipversion_ok {
|
||||
my ( $version ) = @_;
|
||||
|
||||
if ( $version == $IP_VERSION_4 ) {
|
||||
return Zonemaster::Engine::Profile->effective->get( q{net.ipv4} );
|
||||
}
|
||||
elsif ( $version == $IP_VERSION_6 ) {
|
||||
return Zonemaster::Engine::Profile->effective->get( q{net.ipv6} );
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub test_levels {
|
||||
return Zonemaster::Engine::Profile->effective->get( q{test_levels} );
|
||||
}
|
||||
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
sub name {
|
||||
# We do not unpack @_ here for performance reasons.
|
||||
# If we did, the calling convention is: my ( $name ) = @_.
|
||||
return Zonemaster::Engine::DNSName->new( @_ );
|
||||
}
|
||||
|
||||
# Function from CPAN package Text::Capitalize that causes
|
||||
# issues when installing ZM.
|
||||
#
|
||||
sub scramble_case {
|
||||
my $string = shift;
|
||||
my ( @chars, $uppity, $newstring, $uppers, $downers );
|
||||
|
||||
@chars = split //, $string;
|
||||
|
||||
$uppers = 2;
|
||||
$downers = 1;
|
||||
foreach my $c ( @chars ) {
|
||||
$uppity = int( rand( 1 + $downers / $uppers ) );
|
||||
|
||||
if ( $uppity ) {
|
||||
$c = uc( $c );
|
||||
$uppers++;
|
||||
}
|
||||
else {
|
||||
$c = lc( $c );
|
||||
$downers++;
|
||||
}
|
||||
}
|
||||
$newstring = join q{}, @chars;
|
||||
return $newstring;
|
||||
} # end sub scramble_case
|
||||
|
||||
sub parse_hints {
|
||||
my $string = shift;
|
||||
|
||||
# Reject anything that is forbidden in hints files but allowed in zone files
|
||||
# in general.
|
||||
if ( $string =~ /^\$(TTL|INCLUDE|ORIGIN|GENERATE)/m ) {
|
||||
die "Forbidden directive \$$1\n";
|
||||
}
|
||||
|
||||
my $rrs = Net::DNS::ZoneFile->parse( \$string );
|
||||
if ( !defined $rrs ) {
|
||||
die "Unable to parse root hints\n";
|
||||
}
|
||||
|
||||
my %ns;
|
||||
my %glue;
|
||||
for my $rr ( @$rrs ) {
|
||||
if ( $rr->class ne 'IN' ) {
|
||||
my $rrclass = $rr->class;
|
||||
die "Forbidden RR class $rrclass\n";
|
||||
}
|
||||
|
||||
if ( $rr->type eq 'NS' ) {
|
||||
if ( $rr->owner ne '.' ) {
|
||||
my $owner = $rr->owner;
|
||||
die "Owner name for NS record must be \".\"\n";
|
||||
}
|
||||
$ns{ $rr->nsdname } = 0;
|
||||
}
|
||||
elsif ( $rr->type eq 'A' || $rr->type eq 'AAAA' ) {
|
||||
$glue{ $rr->owner } = $rr->type;
|
||||
}
|
||||
else {
|
||||
my $rrtype = $rr->type;
|
||||
die "Forbidden RR type $rrtype\n";
|
||||
}
|
||||
} ## end for my $rr ( @$rrs )
|
||||
|
||||
for my $owner ( sort keys %glue ) {
|
||||
if ( exists $ns{$owner} ) {
|
||||
$ns{$owner} = 1;
|
||||
}
|
||||
else {
|
||||
my $rrtype = $glue{$owner};
|
||||
die "Owner name of $rrtype record does not match any NS RDATA\n";
|
||||
}
|
||||
}
|
||||
|
||||
for my $nsdname ( sort keys %ns ) {
|
||||
if ( $ns{$nsdname} == 0 ) {
|
||||
die "No address record found for NS $nsdname\n";
|
||||
}
|
||||
}
|
||||
|
||||
if ( !%ns ) {
|
||||
die "No NS record found\n";
|
||||
}
|
||||
|
||||
# Extract hint data
|
||||
my %hints;
|
||||
for my $rr ( @{ $rrs } ) {
|
||||
if ( $rr->type eq 'A' or $rr->type eq 'AAAA' ) {
|
||||
push @{ $hints{$rr->owner} }, $rr->address;
|
||||
}
|
||||
}
|
||||
|
||||
return \%hints;
|
||||
}
|
||||
|
||||
sub serial_gt {
|
||||
my ( $sa, $sb ) = @_;
|
||||
|
||||
return ( ( $sa < $sb and ( ($sb - $sa) > 2**( $SERIAL_BITS - 1 ) ) ) or
|
||||
( $sa > $sb and ( ($sa - $sb) < 2**( $SERIAL_BITS - 1 ) ) )
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Util - utility functions for other Zonemaster modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Zonemaster::Engine::Util;
|
||||
info(TAG => { some => 'argument'});
|
||||
my $ns = ns($name, $address);
|
||||
my $name = name('whatever.example.org');
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
=over
|
||||
|
||||
=item info($tag, $href)
|
||||
|
||||
Creates and returns a L<Zonemaster::Engine::Logger::Entry> object. The object
|
||||
is also added to the global logger object's list of entries.
|
||||
|
||||
=item ns($name, $address)
|
||||
|
||||
Creates and returns a nameserver object with the given name and address.
|
||||
|
||||
=item name($string_name_or_zone)
|
||||
|
||||
Creates and returns a L<Zonemaster::Engine::DNSName> object for the given argument.
|
||||
|
||||
=item zone($name)
|
||||
|
||||
Returns a L<Zonemaster::Engine::Zone> object for the given name.
|
||||
|
||||
=item parse_hints($string)
|
||||
|
||||
Parses a string in the root hints format into the format expected by
|
||||
Zonemaster::Engine::Resolver->add_fake_addresses().
|
||||
|
||||
Returns a hashref with domain names as keys and arrayrefs to IP addresses as
|
||||
values.
|
||||
|
||||
Throws an exception if the inputs is not valid root hints text.
|
||||
|
||||
A root hints file is a valid RFC 1035 zone file of the same type IANA publishes
|
||||
to be used as hint file for name servers
|
||||
L<https://www.internic.net/domain/named.root>.
|
||||
|
||||
In addition to being valid zone file the following restrictions are imposed on
|
||||
the root hints format:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
The file must not contain any $TTL, $ORIGIN, $INCLUDE or $GENERATE directives.
|
||||
|
||||
=item *
|
||||
The class field of all records must be "IN" or absent. If class is absent, IN is
|
||||
assumed.
|
||||
|
||||
=item *
|
||||
The TTL field may be absent or present. The TTL value is ignored.
|
||||
|
||||
=item *
|
||||
The RR type of all DNS records must be NS, A or AAAA.
|
||||
|
||||
=item *
|
||||
The file must contain at least one NS record.
|
||||
|
||||
=item *
|
||||
The owner name of all NS records must be C<.>.
|
||||
|
||||
=item *
|
||||
For every NS record there must be at least one address record (A or AAAA) whose
|
||||
owner name is identical to the domain name in the RDATA of the NS record.
|
||||
|
||||
=item *
|
||||
All address records (A or AAAA) must have an owner name that is identical to the
|
||||
domain name in the RDATA of some NS record in the zone.
|
||||
|
||||
=back
|
||||
|
||||
=item serial_gt($serial_a, $serial_b)
|
||||
Checks if serial_a is greater than serial_b, according to
|
||||
serial number arithmetic as defined in RFC1982, section 3.2.
|
||||
|
||||
Return a boolean.
|
||||
|
||||
=item scramble_case
|
||||
|
||||
This routine provides a special effect: sCraMBliNg tHe CaSe
|
||||
|
||||
=item should_run_test
|
||||
|
||||
Check if a test is blacklisted and should run or not.
|
||||
|
||||
=item ipversion_ok
|
||||
|
||||
Check if IP version operations are permitted. Tests are done against Zonemaster::Engine::Profile->effective content.
|
||||
|
||||
=item test_levels
|
||||
|
||||
WIP, here to please L<Pod::Coverage>.
|
||||
|
||||
=back
|
||||
94
zonemaster-engine/lib/Zonemaster/Engine/Validation.pm
Normal file
94
zonemaster-engine/lib/Zonemaster/Engine/Validation.pm
Normal file
@@ -0,0 +1,94 @@
|
||||
package Zonemaster::Engine::Validation;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.0.0");
|
||||
|
||||
use Exporter 'import';
|
||||
BEGIN {
|
||||
our @EXPORT_OK = qw[
|
||||
validate_ipv4
|
||||
validate_ipv6
|
||||
];
|
||||
our %EXPORT_TAGS = ( all => \@EXPORT_OK );
|
||||
|
||||
## no critic (Modules::ProhibitAutomaticExportation)
|
||||
our @EXPORT = qw[
|
||||
validate_ipv4
|
||||
validate_ipv6
|
||||
];
|
||||
}
|
||||
|
||||
use Readonly;
|
||||
use Net::IP::XS;
|
||||
|
||||
use Zonemaster::Engine::Constants qw[:ip];
|
||||
|
||||
Readonly our $IPV4_RE => qr/^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/;
|
||||
Readonly our $IPV6_RE => qr/^[0-9a-f:]*:[0-9a-f:]+(:[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})?$/i;
|
||||
|
||||
sub validate_ipv4 {
|
||||
my ( $ip ) = @_;
|
||||
|
||||
if ( defined $ip and $ip ne '') {
|
||||
if ( Net::IP::XS->new( $ip ) ) {
|
||||
if ( Net::IP::XS::ip_is_ipv4( $ip ) and $ip =~ /($IPV4_RE)/ ) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub validate_ipv6 {
|
||||
my ( $ip ) = @_;
|
||||
|
||||
if ( defined $ip and $ip ne '' ) {
|
||||
if ( Net::IP::XS->new( $ip ) ) {
|
||||
if ( Net::IP::XS::ip_is_ipv6( $ip ) and $ip =~ /($IPV6_RE)/ ) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Validation - validation functions for other Zonemaster modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Zonemaster::Engine::Validation qw( validate_ipv4 validate_ipv6 );
|
||||
my $ip_is_valid = validate_ipv4( $ip_address );
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
=over
|
||||
|
||||
=item validate_ipv4
|
||||
|
||||
my $ip_is_valid = validate_ipv4( $ip_address );
|
||||
|
||||
Checks if the given IP address is a valid IPv4 address.
|
||||
|
||||
Takes a string (IP address).
|
||||
|
||||
Returns a boolean.
|
||||
|
||||
=item validate_ipv6
|
||||
|
||||
my $ip_is_valid = validate_ipv6( $ip_address );
|
||||
|
||||
Checks if the given IP address is a valid IPv6 address.
|
||||
|
||||
Takes a string (IP address).
|
||||
|
||||
Returns a boolean.
|
||||
|
||||
=back
|
||||
486
zonemaster-engine/lib/Zonemaster/Engine/Zone.pm
Normal file
486
zonemaster-engine/lib/Zonemaster/Engine/Zone.pm
Normal file
@@ -0,0 +1,486 @@
|
||||
package Zonemaster::Engine::Zone;
|
||||
|
||||
use v5.16.0;
|
||||
use warnings;
|
||||
|
||||
use version; our $VERSION = version->declare("v1.1.9");
|
||||
|
||||
use Carp qw( confess croak );
|
||||
use List::MoreUtils qw[uniq];
|
||||
|
||||
use Zonemaster::Engine::DNSName;
|
||||
use Zonemaster::Engine::Recursor;
|
||||
use Zonemaster::Engine::NSArray;
|
||||
use Zonemaster::Engine::Constants qw[:ip];
|
||||
|
||||
sub new {
|
||||
my ( $class, $attrs ) = @_;
|
||||
|
||||
my $name = delete $attrs->{name} // confess "required argument 'name' not found";
|
||||
if ( %$attrs ) {
|
||||
confess "unexpected arguments: " . join ', ', sort keys %$attrs;
|
||||
}
|
||||
|
||||
if ( blessed $name ne 'Zonemaster::Engine::DNSName' ) {
|
||||
confess "argument 'name' must be a Zonemaster::Engine::DNSName";
|
||||
}
|
||||
|
||||
my $obj = { _name => $name };
|
||||
|
||||
return bless $obj, $class;
|
||||
}
|
||||
|
||||
sub name {
|
||||
my ( $self ) = @_;
|
||||
|
||||
return $self->{_name};
|
||||
}
|
||||
|
||||
sub parent {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_parent} ) {
|
||||
$self->{_parent} = $self->_build_parent;
|
||||
}
|
||||
|
||||
return $self->{_parent};
|
||||
}
|
||||
|
||||
sub glue_names {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_glue_names} ) {
|
||||
$self->{_glue_names} = $self->_build_glue_names;
|
||||
}
|
||||
|
||||
return $self->{_glue_names};
|
||||
}
|
||||
|
||||
sub glue {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_glue} ) {
|
||||
$self->{_glue} = $self->_build_glue;
|
||||
}
|
||||
|
||||
return $self->{_glue};
|
||||
}
|
||||
|
||||
sub ns_names {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_ns_names} ) {
|
||||
$self->{_ns_names} = $self->_build_ns_names;
|
||||
}
|
||||
|
||||
return $self->{_ns_names};
|
||||
}
|
||||
|
||||
sub ns {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_ns} ) {
|
||||
$self->{_ns} = $self->_build_ns;
|
||||
}
|
||||
|
||||
return $self->{_ns};
|
||||
}
|
||||
|
||||
sub glue_addresses {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( !exists $self->{_glue_addresses} ) {
|
||||
$self->{_glue_addresses} = $self->_build_glue_addresses;
|
||||
}
|
||||
|
||||
return $self->{_glue_addresses};
|
||||
}
|
||||
|
||||
###
|
||||
### Builders
|
||||
###
|
||||
|
||||
sub _build_parent {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->name eq '.' ) {
|
||||
return $self;
|
||||
}
|
||||
|
||||
my $pname = Zonemaster::Engine::Recursor->parent( q{} . $self->name );
|
||||
return if not $pname;
|
||||
## no critic (Modules::RequireExplicitInclusion)
|
||||
return __PACKAGE__->new( { name => $pname } );
|
||||
}
|
||||
|
||||
sub _build_glue_names {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( not $self->parent ) {
|
||||
return [];
|
||||
}
|
||||
|
||||
my $p = $self->parent->query_persistent( $self->name, 'NS' );
|
||||
|
||||
return [] if not defined $p;
|
||||
|
||||
return [ uniq sort map { Zonemaster::Engine::DNSName->new( lc( $_->nsdname ) ) }
|
||||
$p->get_records_for_name( 'ns', $self->name->string ) ];
|
||||
}
|
||||
|
||||
sub _build_glue {
|
||||
my ( $self ) = @_;
|
||||
my @glue_names = @{ $self->glue_names };
|
||||
my $zname = $self->name->string;
|
||||
|
||||
if ( Zonemaster::Engine::Recursor->has_fake_addresses( $zname ) ) {
|
||||
my @ns_list;
|
||||
foreach my $ns ( @glue_names ) {
|
||||
foreach my $ip ( Zonemaster::Engine::Recursor->get_fake_addresses( $zname, $ns ) ) {
|
||||
push @ns_list, Zonemaster::Engine::Nameserver->new( { name => $ns, address => $ip } );
|
||||
}
|
||||
}
|
||||
return \@ns_list;
|
||||
}
|
||||
else {
|
||||
|
||||
my $aref = [];
|
||||
tie @$aref, 'Zonemaster::Engine::NSArray', @glue_names;
|
||||
|
||||
return $aref;
|
||||
}
|
||||
}
|
||||
|
||||
sub _build_ns_names {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->name eq '.' ) {
|
||||
my %u;
|
||||
$u{$_} = $_ for map { $_->name } @{ $self->ns };
|
||||
return [ sort values %u ];
|
||||
}
|
||||
|
||||
my $p;
|
||||
my $i = 0;
|
||||
while ( my $s = $self->glue->[$i] ) {
|
||||
$p = $s->query( $self->name, 'NS' );
|
||||
last if ( defined( $p ) and ( $p->type eq 'answer' ) and ( $p->rcode eq 'NOERROR' ) );
|
||||
$i += 1;
|
||||
}
|
||||
return [] if not defined $p;
|
||||
|
||||
return [ uniq sort map { Zonemaster::Engine::DNSName->new( lc( $_->nsdname ) ) }
|
||||
$p->get_records_for_name( 'ns', $self->name->string ) ];
|
||||
} ## end sub _build_ns_names
|
||||
|
||||
sub _build_ns {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( $self->name eq '.' ) { # Root is a special case
|
||||
return [ Zonemaster::Engine::Recursor->root_servers ];
|
||||
}
|
||||
|
||||
my $aref = [];
|
||||
tie @$aref, 'Zonemaster::Engine::NSArray', @{ $self->ns_names };
|
||||
|
||||
return $aref;
|
||||
}
|
||||
|
||||
sub _build_glue_addresses {
|
||||
my ( $self ) = @_;
|
||||
|
||||
if ( not $self->parent ) {
|
||||
return [];
|
||||
}
|
||||
|
||||
my $p = $self->parent->query_one( $self->name, 'NS' );
|
||||
croak "Failed to get glue addresses" if not defined( $p );
|
||||
|
||||
return [ $p->get_records( 'a' ), $p->get_records( 'aaaa' ) ];
|
||||
}
|
||||
|
||||
sub _is_ip_version_disabled {
|
||||
my ( $ns, $type ) = @_;
|
||||
|
||||
if ( not Zonemaster::Engine::Profile->effective->get(q{net.ipv4}) and $ns->address->version == $IP_VERSION_4 ) {
|
||||
Zonemaster::Engine->logger->add(
|
||||
SKIP_IPV4_DISABLED => {
|
||||
ns => $ns->string,
|
||||
rrtype => $type
|
||||
}
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ( not Zonemaster::Engine::Profile->effective->get(q{net.ipv6}) and $ns->address->version == $IP_VERSION_6 ) {
|
||||
Zonemaster::Engine->logger->add(
|
||||
SKIP_IPV6_DISABLED => {
|
||||
ns => $ns->string,
|
||||
rrtype => $type
|
||||
}
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
###
|
||||
### Public Methods
|
||||
###
|
||||
|
||||
sub query_one {
|
||||
my ( $self, $name, $type, $flags ) = @_;
|
||||
|
||||
# Return response from the first server that gives one
|
||||
my $i = 0;
|
||||
while ( my $ns = $self->ns->[$i] ) {
|
||||
if ( _is_ip_version_disabled( $ns, $type ) ) {
|
||||
next;
|
||||
}
|
||||
|
||||
my $p = $ns->query( $name, $type, $flags );
|
||||
return $p if defined( $p );
|
||||
}
|
||||
continue {
|
||||
$i += 1;
|
||||
}
|
||||
|
||||
return;
|
||||
} ## end sub query_one
|
||||
|
||||
sub query_all {
|
||||
my ( $self, $name, $type, $flags ) = @_;
|
||||
|
||||
my @servers = @{ $self->ns };
|
||||
|
||||
if ( not Zonemaster::Engine::Profile->effective->get(q{net.ipv4}) ) {
|
||||
my @nope = grep { $_->address->version == $IP_VERSION_4 } @servers;
|
||||
@servers = grep { $_->address->version == $IP_VERSION_6 } @servers;
|
||||
map {
|
||||
Zonemaster::Engine->logger->add(
|
||||
SKIP_IPV4_DISABLED => {
|
||||
ns => $_->string,
|
||||
rrtype => $type
|
||||
}
|
||||
)
|
||||
} @nope;
|
||||
}
|
||||
|
||||
if ( not Zonemaster::Engine::Profile->effective->get(q{net.ipv6}) ) {
|
||||
my @nope = grep { $_->address->version == $IP_VERSION_6 } @servers;
|
||||
@servers = grep { $_->address->version == $IP_VERSION_4 } @servers;
|
||||
map {
|
||||
Zonemaster::Engine->logger->add(
|
||||
SKIP_IPV6_DISABLED => {
|
||||
ns => $_->string,
|
||||
rrtype => $type
|
||||
}
|
||||
)
|
||||
} @nope;
|
||||
}
|
||||
|
||||
return [ map { $_->query( $name, $type, $flags ) } @servers ];
|
||||
}
|
||||
|
||||
sub query_auth {
|
||||
my ( $self, $name, $type, $flags ) = @_;
|
||||
|
||||
# Return response from the first server that replies with AA set
|
||||
my $i = 0;
|
||||
while ( my $ns = $self->ns->[$i] ) {
|
||||
if ( _is_ip_version_disabled( $ns, $type ) ) {
|
||||
next;
|
||||
}
|
||||
|
||||
my $p = $ns->query( $name, $type, $flags );
|
||||
if ( $p and $p->aa ) {
|
||||
return $p;
|
||||
}
|
||||
}
|
||||
continue {
|
||||
$i += 1;
|
||||
}
|
||||
|
||||
return;
|
||||
} ## end sub query_auth
|
||||
|
||||
sub query_persistent {
|
||||
my ( $self, $name, $type, $flags ) = @_;
|
||||
|
||||
# Return response from the first server that has a record like the one asked for
|
||||
my $i = 0;
|
||||
while ( my $ns = $self->ns->[$i] ) {
|
||||
if ( _is_ip_version_disabled( $ns, $type ) ) {
|
||||
next;
|
||||
}
|
||||
|
||||
my $p = $ns->query( $name, $type, $flags );
|
||||
if ( $p and scalar( $p->get_records_for_name( $type, $name ) ) > 0 ) {
|
||||
return $p;
|
||||
}
|
||||
}
|
||||
continue {
|
||||
$i += 1;
|
||||
}
|
||||
|
||||
return;
|
||||
} ## end sub query_persistent
|
||||
|
||||
sub is_in_zone {
|
||||
my ( $self, $name ) = @_;
|
||||
|
||||
if ( not ref( $name ) or ref( $name ) ne 'Zonemaster::Engine::DNSName' ) {
|
||||
$name = Zonemaster::Engine::DNSName->new( $name );
|
||||
}
|
||||
|
||||
if ( scalar( @{ $self->name->labels } ) != $self->name->common( $name ) ) {
|
||||
return 0; # Zone name cannot be a suffix of tested name
|
||||
}
|
||||
|
||||
my $p = $self->query_auth( "$name", 'SOA' );
|
||||
if ( not $p ) {
|
||||
return;
|
||||
}
|
||||
|
||||
if ( $p->is_redirect ) {
|
||||
return 0; # Authoritative servers redirect us, so name must be out-of-zone
|
||||
}
|
||||
|
||||
my ( $soa ) = $p->get_records( 'SOA' );
|
||||
|
||||
if ( not $soa ) {
|
||||
return 0; # Auth server is broken, call it a "no".
|
||||
}
|
||||
|
||||
if ( Zonemaster::Engine::DNSName->new( $soa->name ) eq $self->name ) {
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
return 0;
|
||||
}
|
||||
} ## end sub is_in_zone
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Zonemaster::Engine::Zone - Object representing a DNS zone
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $zone = Zonemaster::Engine::Zone->new({ name => 'nic.se' });
|
||||
my $packet = $zone->parent->query_one($zone->name, 'NS');
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Objects of this class represent zones in DNS. As far as possible, test
|
||||
implementations should access information about zones via these
|
||||
objects. Doing so will provide lazy-loading of the information,
|
||||
well-defined methods in which the information is fetched, logging and
|
||||
the ability to do things like testing zones that have not yet been
|
||||
delegated.
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
=over
|
||||
|
||||
=item new
|
||||
|
||||
Construct a new instance.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over
|
||||
|
||||
=item name
|
||||
|
||||
A L<Zonemaster::Engine::DNSName> object representing the name of the zone.
|
||||
|
||||
=item parent
|
||||
|
||||
A L<Zonemaster::Engine::Zone> object for this domain's parent domain. As a
|
||||
special case, the root zone is considered to be its own parent (so
|
||||
look for that if you recurse up the tree).
|
||||
|
||||
=item ns_names
|
||||
|
||||
A reference to an array of L<Zonemaster::Engine::DNSName> objects, holding the
|
||||
names of the nameservers for the domain, as returned by the first
|
||||
responding nameserver in the glue list.
|
||||
|
||||
=item ns
|
||||
|
||||
A reference to an array of L<Zonemaster::Engine::Nameserver> objects for the
|
||||
domain, built by taking the list returned from L<ns_names()> and
|
||||
looking up addresses for the names. One element will be added to this
|
||||
list for each unique name/IP pair. Names for which no addresses could
|
||||
be found will not be in this list. The list is lazy-loading, so take
|
||||
care to only look at as many entries as you really need. There are
|
||||
zones with more than 20 nameserver, and looking up the addresses of
|
||||
them all can take som considerable time.
|
||||
|
||||
=item glue_names
|
||||
|
||||
A reference to a an array of L<Zonemaster::Engine::DNSName> objects, holding the names
|
||||
of this zones nameservers as listed at the first responding nameserver of the
|
||||
parent zone.
|
||||
|
||||
=item glue
|
||||
|
||||
A reference to an array of L<Zonemaster::Engine::Nameserver> objects for the
|
||||
domain, built by taking the list returned from L<glue_names()> and
|
||||
looking up addresses for the names. One element will be added to this
|
||||
list for each unique name/IP pair. Names for which no addresses could
|
||||
be found will not be in this list. In this case, the list is lazy-loading, so take
|
||||
care to only look at as many entries as you really need. In case of
|
||||
undelegated tests and fake delegation the IP associated with name servers
|
||||
for the tested zone will be the ones set by users (saved in
|
||||
%Zonemaster::Engine::Recursor::fake_addresses_cache), instead of the ones
|
||||
found recursively.
|
||||
|
||||
=item glue_addresses
|
||||
|
||||
A list of L<Zonemaster::LDNS::RR::A> and L<Zonemaster::LDNS::RR::AAAA> records returned in
|
||||
the Additional section of an NS query to the first listed nameserver for the
|
||||
parent domain.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item query_one($name[, $type[, $flags]])
|
||||
|
||||
Sends (or retrieves from cache) a query for the given name, type and flags sent to the first nameserver in the zone's ns list. If there is a
|
||||
response, it will be returned in a L<Zonemaster::Engine::Packet> object. If the type arguments is not given, it defaults to 'A'. If the flags are not given, they default to C<class> IN and C<dnssec>, C<usevc> and C<recurse> according to configuration (which is by default off on all three).
|
||||
|
||||
=item query_persistent($name[, $type[, $flags]])
|
||||
|
||||
Identical to L<query_one>, except that instead of returning the packet from the
|
||||
first server that returns one, it returns the first packet that actually
|
||||
contains a resource record matching the requested name and type.
|
||||
|
||||
=item query_auth($name[, $type[, $flags]])
|
||||
|
||||
Identical to L<query_one>, except that instead of returning the packet from the
|
||||
first server that returns one, it returns the first packet that has the AA flag set.
|
||||
|
||||
=item query_all($name, $type, $flags)
|
||||
|
||||
Sends (or retrieves from cache) queries to all the nameservers listed in the zone's ns list, and returns a reference to an array with the
|
||||
responses. The responses can be either L<Zonemaster::Engine::Packet> objects or C<undef> values. The arguments are the same as for L<query_one>.
|
||||
|
||||
=item is_in_zone($name)
|
||||
|
||||
Returns true if the given name is in the zone, false if not. If it could not be
|
||||
determined with a sufficient degree of certainty if the name is in the zone or
|
||||
not, C<undef> is returned.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user