File Coverage

blib/lib/Net/DNS/RR/NSEC3.pm

Criterion	Covered	Total	%
statement	179	179	100.0
branch	38	38	100.0
condition	23	23	100.0
subroutine	32	32	100.0
pod	12	14	100.0
total	284	286	100.0

package Net::DNS::RR::NSEC3;

use strict;
use warnings;
our $VERSION = (qw$Id: NSEC3.pm 1910 2023-03-30 19:16:30Z willem $)[2];

use base qw(Net::DNS::RR::NSEC);


=head1 NAME

Net::DNS::RR::NSEC3 - DNS NSEC3 resource record

=cut

use integer;

use base qw(Exporter);
our @EXPORT_OK = qw(name2hash);

use Carp;

require Net::DNS::DomainName;

eval { require Digest::SHA };		## optional for simple Net::DNS RR


sub _decode_rdata {			## decode rdata from wire-format octet string
	my ( $self, $data, $offset ) = @_;

	my $limit = $offset + $self->{rdlength};
	my $ssize = unpack "\@$offset x4 C", $$data;
	my ( $algorithm, $flags, $iterations, $saltbin ) = unpack "\@$offset CCnx a$ssize", $$data;
	@{$self}{qw(algorithm flags iterations saltbin)} = ( $algorithm, $flags, $iterations, $saltbin );
	$offset += 5 + $ssize;
	my $hsize = unpack "\@$offset C", $$data;
	$self->{hnxtname} = unpack "\@$offset x a$hsize", $$data;
	$offset += 1 + $hsize;
	$self->{typebm} = substr $$data, $offset, ( $limit - $offset );
	$self->{hashfn} = _hashfn( $algorithm, $iterations, $saltbin );
	return;
}


sub _encode_rdata {			## encode rdata as wire-format octet string
	my $self = shift;

	my $salt = $self->saltbin;
	my $hash = $self->{hnxtname};
	return pack 'CCn C a* C a* a*', $self->algorithm, $self->flags, $self->iterations,
			length($salt), $salt,
			length($hash), $hash,
			$self->{typebm};
}


sub _format_rdata {			## format rdata portion of RR string.
	my $self = shift;

	my @rdata = (
		$self->algorithm,   $self->flags,    $self->iterations,
		$self->salt || '-', $self->hnxtname, $self->typelist
		);
	return @rdata;
}


sub _parse_rdata {			## populate RR from rdata in argument list
	my ( $self, @argument ) = @_;

	my $alg = $self->algorithm( shift @argument );
	$self->flags( shift @argument );
	my $iter = $self->iterations( shift @argument );
	my $salt = shift @argument;
	$self->salt($salt) unless $salt eq '-';
	$self->hnxtname( shift @argument );
	$self->typelist(@argument);
	$self->{hashfn} = _hashfn( $alg, $iter, $self->{saltbin} );
	return;
}


sub _defaults {				## specify RR attribute default values
	my $self = shift;

	$self->_parse_rdata( 1, 0, 0, '' );
	return;
}


sub algorithm {
	my ( $self, $arg ) = @_;

	unless ( ref($self) ) {		## class method or simple function
		my $argn = pop;
		return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn);
	}

	return $self->{algorithm} unless defined $arg;
	return _digestbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i;
	return $self->{algorithm} = _digestbyname($arg);
}


sub flags {
	my ( $self, @value ) = @_;
	for (@value) { $self->{flags} = 0 + $_ }
	return $self->{flags} || 0;
}


sub optout {
	my ( $self, @value ) = @_;
	for ( $self->{flags} |= 0 ) {
		if ( scalar @value ) {
			$_ |= 0x01;
			$_ ^= 0x01 unless shift @value;
		}
	}
	return $self->{flags} & 0x01;
}


sub iterations {
	my ( $self, @value ) = @_;
	for (@value) { $self->{iterations} = 0 + $_ }
	return $self->{iterations} || 0;
}


sub salt {
	my ( $self, @value ) = @_;
	return unpack "H*", $self->saltbin() unless scalar @value;
	my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value;
	return $self->saltbin( pack "H*", join "", @hex );
}


sub saltbin {
	my ( $self, @value ) = @_;
	for (@value) { $self->{saltbin} = $_ }
	return $self->{saltbin} || "";
}


sub hnxtname {
	my ( $self, @name ) = @_;
	for (@name) { $self->{hnxtname} = _decode_base32hex($_) }
	return defined(wantarray) ? _encode_base32hex( $self->{hnxtname} ) : undef;
}


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

	my ($owner) = $self->{owner}->label;
	my $ownerhash = _decode_base32hex($owner);

	my $hashfn = $self->{hashfn};
	return $ownerhash eq &$hashfn($name);
}

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

	my ( $owner, @zone ) = $self->{owner}->label;
	my $ownerhash = _decode_base32hex($owner);
	my $nexthash  = $self->{hnxtname};

	my @label = Net::DNS::DomainName->new($name)->label;
	my @close = @label;
	foreach (@zone) { pop(@close) }				# strip zone labels
	return if lc($name) ne lc( join '.', @close, @zone );	# out of zone

	my $hashfn = $self->{hashfn};

	foreach (@close) {
		my $hash = &$hashfn( join '.', @label );
		my $cmp1 = $hash cmp $ownerhash;
		last unless $cmp1;				# stop at provable encloser
		return 1 if ( $cmp1 + ( $nexthash cmp $hash ) ) == 2;
		shift @label;
	}
	return;
}


sub encloser {
	my ( $self, $qname ) = @_;

	my ( $owner, @zone ) = $self->{owner}->label;
	my $ownerhash = _decode_base32hex($owner);
	my $nexthash  = $self->{hnxtname};

	my @label = Net::DNS::DomainName->new($qname)->label;
	my @close = @label;
	foreach (@zone) { pop(@close) }				# strip zone labels
	return if lc($qname) ne lc( join '.', @close, @zone );	# out of zone

	my $hashfn = $self->{hashfn};

	my $encloser = $qname;
	foreach (@close) {
		my $nextcloser = $encloser;
		shift @label;
		my $hash = &$hashfn( $encloser = join '.', @label );
		next if $hash ne $ownerhash;
		$self->{nextcloser} = $nextcloser;		# next closer name
		$self->{wildcard}   = "*.$encloser";		# wildcard at provable encloser
		return $encloser;				# provable encloser
	}
	return;
}


sub nextcloser { return shift->{nextcloser}; }

sub wildcard { return shift->{wildcard}; }


########################################

my @digestbyname = (
	'SHA-1' => 1,						# [RFC3658]
	);

my @digestalias = ( 'SHA' => 1 );

my %digestbyval = reverse @digestbyname;

foreach (@digestbyname) { s/[\W_]//g; }				# strip non-alphanumerics
my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname;
my %digestbyname = ( @digestalias, @digestrehash );		# work around broken cperl

sub _digestbyname {
	my $arg = shift;
	my $key = uc $arg;					# synthetic key
	$key =~ s/[\W_]//g;					# strip non-alphanumerics
	my $val = $digestbyname{$key};
	croak qq[unknown algorithm $arg] unless defined $val;
	return $val;
}

sub _digestbyval {
	my $value = shift;
	return $digestbyval{$value} || return $value;
}


my %digest = (
	'1' => scalar( eval { Digest::SHA->new(1) } ),		# RFC3658
	);


sub _decode_base32hex {
	local $_ = shift || '';
	tr [0-9A-Va-v\060-\071\101-\126\141-\166] [\000-\037\012-\037\000-\037\012-\037];
	my $l = ( 5 * length ) & ~7;
	return pack "B$l", join '', map { unpack( 'x3a5', unpack 'B8', $_ ) } split //;
}


sub _encode_base32hex {
	my @split = grep {length} split /(\S{5})/, unpack 'B*', shift;
	local $_ = join '', map { pack( 'B*', "000$_" ) } @split;
	tr [\000-\037] [0-9a-v];
	return $_;
}


my ( $cache1, $cache2, $limit ) = ( {}, {}, 10 );

sub _hashfn {
	my $hashalg    = shift;
	my $iterations = shift || 0;
	my $salt       = shift || '';

	my $hash = $digest{$hashalg};
	return sub { croak "algorithm $hashalg not supported" }
			unless $hash;
	my $clone = $hash->clone;

	my $key_adjunct = pack 'Cna*', $hashalg, $iterations, $salt;

	return sub {
		my $name  = Net::DNS::DomainName->new(shift)->canonical;
		my $key	  = join '', $name, $key_adjunct;
		my $cache = $$cache1{$key} ||= $$cache2{$key};	# two layer cache
		return $cache if defined $cache;
		( $cache1, $cache2, $limit ) = ( {}, $cache1, 50 ) unless $limit--;    # recycle cache

		$clone->add($name);
		$clone->add($salt);
		my $digest = $clone->digest;
		my $count  = $iterations;
		while ( $count-- ) {
			$clone->add($digest);
			$clone->add($salt);
			$digest = $clone->digest;
		}
		return $$cache1{$key} = $digest;
	};
}


sub hashalgo { return &algorithm; }				# uncoverable pod

sub name2hash {
	my $hashalg    = shift;					# uncoverable pod
	my $name       = shift;
	my $iterations = shift || 0;
	my $salt       = pack 'H*', shift || '';
	my $hash       = _hashfn( $hashalg, $iterations, $salt );
	return _encode_base32hex( &$hash($name) );
}

########################################


1;
__END__