Recursor.pm

package Zonemaster::Engine::Recursor;

use version; our $VERSION = version->declare("v1.0.10");

use 5.014002;
use warnings;

use Moose;
use JSON::PP;
use Zonemaster::Engine::Util;
use Zonemaster::Engine::Net::IP;
use Zonemaster::Engine;

my $seed_data;

our %recurse_cache;
our %fake_addresses_cache;

{
    local $/;
    my $json = <DATA>;
    $seed_data = decode_json $json;
}

sub add_fake_addresses {
    my ( $self, $domain, $href ) = @_;

    foreach my $name ( keys %{$href} ) {
        push @{ $fake_addresses_cache{$domain}{$name} }, ();
        foreach my $ip (@{ $href->{$name} }) {
            push @{ $fake_addresses_cache{$domain}{$name} }, $ip;
        }
    }

    return;
}

sub recurse {
    my ( $self, $name, $type, $class ) = @_;
    $name = name( $name );
    $type  //= 'A';
    $class //= 'IN';

    Zonemaster::Engine->logger->add( RECURSE => { name => $name, type => $type, class => $class } );
    if ( exists $recurse_cache{$name}{$type}{$class} ) {
        return $recurse_cache{$name}{$type}{$class};
    }

    my ( $p, $state ) =
      $self->_recurse( $name, $type, $class,
        { ns => [ root_servers() ], count => 0, common => 0, seen => {}, glue => {} } );
    $recurse_cache{$name}{$type}{$class} = $p;

    return $p;
}

sub parent {
    my ( $self, $name ) = @_;
    $name = name( $name );

    my ( $p, $state ) =
      $self->_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 _recurse {
    my ( $self, $name, $type, $class, $state ) = @_;
    $name = q{} . name( $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   => $class
            }
        );
        my $p = $self->_do_query( $ns, $name, $type, { class => $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 ( $self->_is_answer( $p ) ) {    # Return answer
            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} = $self->get_ns_from( $p, $state );    # Follow redirect
            $state->{count} += 1;
            return ( undef, $state ) if $state->{count} > 20;    # Loop protection
            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 ( $self, $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( name( $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 = $self->_do_query( $realns, $name, $type, $opts, $state );
            if ( $p ) {
                return $p;
            }
        }
    }
    else {
        $state->{glue}{ lc( name( $ns ) ) } = {};
        my @addr = $self->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;
            }
        }
        else {
            return;
        }
    }
} ## end sub _do_query

sub get_ns_from {
    my ( $self, $p, $state ) = @_;
    my ( @new, @extra );

    my @names = sort map { name( lc( $_->nsdname ) ) } $p->get_records( 'ns' );

    $state->{glue}{ lc( name( $_->name ) ) }{ $_->address } = 1
      for ( $p->get_records( 'a' ), $p->get_records( 'aaaa' ) );

    foreach my $name ( @names ) {
        if ( exists $state->{glue}{ lc( name( $name ) ) } ) {
            for my $addr ( keys %{ $state->{glue}{ lc( name( $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 ( $self, $name, $state ) = @_;
    my @res;
    $state //=
      { ns => [ root_servers() ], count => 0, common => 0, seen => {} };

    my ( $pa ) = $self->_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 ) = $self->_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, Zonemaster::Engine::Net::IP->new( $rr->address );
        }
    }
    return @res;
} ## end sub get_addresses_for

sub _is_answer {
    my ( $self, $packet ) = @_;

    return ( $packet->type eq 'answer' );
}

sub clear_cache {
    %recurse_cache = ();
}

sub root_servers {
    return map { Zonemaster::Engine::Util::ns( $_->{name}, $_->{address} ) }
      sort { $a->{name} cmp $b->{name} } @{ $seed_data->{'.'} };
}

no Moose;
__PACKAGE__->meta->make_immutable;

1;

=head1 NAME

Zonemaster::Engine::Recursor - recursive resolver for Zonemaster

=head1 SYNOPSIS

    my $packet = Zonemaster::Engine::Recursor->recurse($name, $type, $class);
    my $pname = Zonemaster::Engine::Recursor->parent('example.org');

=head1 CLASS VARIABLES

=over

=item %recurse_cache

Will cache result of previous queries.

=item %fake_addresses_cache

Contains namservers IP addresses which are used in case of fake delegations 
(pre-publication tests).

=back

=head1 METHODS

=over

=item recurse($name, $type, $class)

Does a recursive resolution from the root servers down for the given triplet.

=item 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.

=item 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.

=item 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<Zonemaster::Engine::Net::IP> objects). When used
internally by the recursor it's passed a recursion state as its second
argument.

=item add_fake_addresses($domain, $data)

Class method to create fake adresses for fake delegations for a specified domain from data provided.

=item clear_cache()

Class method to empty the cache of responses to recursive queries (but not the ones for fake delegations).

=item root_servers()

Returns a list of ns objects representing the root servers. The list of root servers is hardcoded into this module.

=back

=cut

__DATA__
{
   "." : [
      {
         "name" : "m.root-servers.net",
         "address" : "202.12.27.33"
      },
      {
         "name" : "m.root-servers.net",
         "address" : "2001:dc3:0:0:0:0:0:35"
      },
      {
         "name" : "e.root-servers.net",
         "address" : "192.203.230.10"
      },
      {
         "address" : "199.7.83.42",
         "name" : "l.root-servers.net"
      },
      {
         "address" : "2001:500:3:0:0:0:0:42",
         "name" : "l.root-servers.net"
      },
      {
         "address" : "198.41.0.4",
         "name" : "a.root-servers.net"
      },
      {
         "address" : "2001:503:ba3e:0:0:0:2:30",
         "name" : "a.root-servers.net"
      },
      {
         "address" : "192.5.5.241",
         "name" : "f.root-servers.net"
      },
      {
         "address" : "2001:500:2f:0:0:0:0:f",
         "name" : "f.root-servers.net"
      },
      {
         "address" : "199.7.91.13",
         "name" : "d.root-servers.net"
      },
      {
         "address" : "2001:500:2d:0:0:0:0:d",
         "name" : "d.root-servers.net"
      },
      {
         "address" : "192.58.128.30",
         "name" : "j.root-servers.net"
      },
      {
         "address" : "2001:503:c27:0:0:0:2:30",
         "name" : "j.root-servers.net"
      },
      {
         "address" : "128.63.2.53",
         "name" : "h.root-servers.net"
      },
      {
         "name" : "h.root-servers.net",
         "address" : "2001:500:1:0:0:0:803f:235"
      },
      {
         "name" : "g.root-servers.net",
         "address" : "192.112.36.4"
      },
      {
         "name" : "k.root-servers.net",
         "address" : "193.0.14.129"
      },
      {
         "address" : "2001:7fd:0:0:0:0:0:1",
         "name" : "k.root-servers.net"
      },
      {
         "name" : "b.root-servers.net",
         "address" : "192.228.79.201"
      },
      {
         "address" : "192.33.4.12",
         "name" : "c.root-servers.net"
      },
      {
         "name" : "i.root-servers.net",
         "address" : "192.36.148.17"
      },
      {
         "name" : "i.root-servers.net",
         "address" : "2001:7fe:0:0:0:0:0:53"
      }
   ]
}