File Coverage

blib/lib/Net/DNS/RR/RRSIG.pm
Criterion Covered Total %
statement 164 164 100.0
branch 48 48 100.0
condition 16 16 100.0
subroutine 43 43 100.0
pod 17 17 100.0
total 288 288 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::RR::RRSIG;
2              
3 2     2   15 use strict;
  2         4  
  2         63  
4 2     2   10 use warnings;
  2         4  
  2         127  
5             our $VERSION = (qw$Id: RRSIG.pm 1896 2023-01-30 12:59:25Z willem $)[2];
6              
7 2     2   30 use base qw(Net::DNS::RR);
  2         5  
  2         162  
8              
9              
10             =head1 NAME
11              
12             Net::DNS::RR::RRSIG - DNS RRSIG resource record
13              
14             =cut
15              
16 2     2   15 use integer;
  2         4  
  2         9  
17              
18 2     2   80 use Carp;
  2         6  
  2         141  
19 2     2   567 use Time::Local;
  2         2368  
  2         161  
20              
21 2     2   16 use Net::DNS::Parameters qw(:type);
  2         5  
  2         299  
22              
23 2     2   16 use constant DEBUG => 0;
  2         3  
  2         158  
24              
25 2     2   13 use constant UTIL => defined eval { require Scalar::Util; };
  2         11  
  2         4  
  2         160  
26              
27             eval { require MIME::Base64 };
28              
29             # IMPORTANT: Downstream distros MUST NOT create dependencies on Net::DNS::SEC (strong crypto prohibited in many territories)
30 2     2   10 use constant USESEC => defined $INC{'Net/DNS/SEC.pm'}; # Discover how we got here, without exposing any crypto
  2         11  
  2         143  
31 2     2   13 use constant DNSSEC => USESEC && defined eval join '', qw(r e q u i r e), ' Net::DNS::SEC::Private'; ## no critic
  2         28  
  2         2516  
32              
33             my @index;
34             if (DNSSEC) {
35             foreach my $class ( map {"Net::DNS::SEC::$_"} qw(RSA DSA ECCGOST ECDSA EdDSA) ) {
36             my @algorithms = eval join '', qw(r e q u i r e), " $class; $class->_index"; ## no critic
37             push @index, map { ( $_ => $class ) } @algorithms;
38             }
39             croak 'Net::DNS::SEC version not supported' unless scalar(@index);
40             }
41              
42             my %DNSSEC_verify = @index;
43             my %DNSSEC_siggen = @index;
44              
45             my @deprecated = ( 1, 3, 6, 12 ); # RFC8624
46             delete @DNSSEC_siggen{@deprecated};
47              
48             my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag);
49              
50              
51             sub _decode_rdata { ## decode rdata from wire-format octet string
52 330     330   614 my ( $self, $data, $offset ) = @_;
53              
54 330         536 my $limit = $offset + $self->{rdlength};
55 330         1060 @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data;
  330         1842  
56 330         1107 ( $self->{signame}, $offset ) = Net::DNS::DomainName->decode( $data, $offset + 18 );
57 330         1182 $self->{sigbin} = substr $$data, $offset, $limit - $offset;
58 330         647 return;
59             }
60              
61              
62             sub _encode_rdata { ## encode rdata as wire-format octet string
63 5     5   9 my $self = shift;
64              
65 5         8 my $signame = $self->{signame};
66 5         8 return pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->canonical, $self->sigbin;
  5         20  
67             }
68              
69              
70             sub _format_rdata { ## format rdata portion of RR string.
71 3     3   5 my $self = shift;
72              
73 3         5 my $signame = $self->{signame};
74 3         6 my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin );
75 3         8 my @rdata = ( map( { $self->$_ } @field ), $signame->string, @sig64 );
  21         54  
76 3         15 return @rdata;
77             }
78              
79              
80             sub _parse_rdata { ## populate RR from rdata in argument list
81 3     3   30 my ( $self, @argument ) = @_;
82              
83 3         9 foreach ( @field, qw(signame) ) { $self->$_( shift @argument ) }
  24         60  
84 3         10 $self->signature(@argument);
85 3         7 return;
86             }
87              
88              
89             sub _defaults { ## specify RR attribute default values
90 2     2   5 my $self = shift;
91              
92 2         6 $self->sigval(30);
93 2         5 return;
94             }
95              
96              
97             sub typecovered {
98 9     9 1 25 my ( $self, @value ) = @_;
99 9         15 for (@value) { $self->{typecovered} = typebyname($_) }
  4         12  
100 9         15 my $typecode = $self->{typecovered};
101 9 100       38 return defined $typecode ? typebyval($typecode) : undef;
102             }
103              
104              
105             sub algorithm {
106 19     19 1 1720 my ( $self, $arg ) = @_;
107              
108 19 100       48 unless ( ref($self) ) { ## class method or simple function
109 3         5 my $argn = pop;
110 3 100       17 return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn);
111             }
112              
113 16 100       49 return $self->{algorithm} unless defined $arg;
114 8 100       21 return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i;
115 7         13 return $self->{algorithm} = _algbyname($arg);
116             }
117              
118              
119             sub labels {
120 9     9 1 1153 my ( $self, @value ) = @_;
121 9         17 for (@value) { $self->{labels} = 0 + $_ }
  4         11  
122 9   100     33 return $self->{labels} || 0;
123             }
124              
125              
126             sub orgttl {
127 9     9 1 1137 my ( $self, @value ) = @_;
128 9         14 for (@value) { $self->{orgttl} = 0 + $_ }
  4         13  
129 9   100     34 return $self->{orgttl} || 0;
130             }
131              
132              
133             sub sigexpiration {
134 11     11 1 1066 my ( $self, @value ) = @_;
135 11         17 for (@value) { $self->{sigexpiration} = _string2time($_) }
  4         8  
136 11         144 my $time = $self->{sigexpiration};
137 11 100 100     45 return unless defined wantarray && defined $time;
138 6         14 return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time);
139             }
140              
141             sub siginception {
142 11     11 1 1136 my ( $self, @value ) = @_;
143 11         19 for (@value) { $self->{siginception} = _string2time($_) }
  4         9  
144 11         114 my $time = $self->{siginception};
145 11 100 100     63 return unless defined wantarray && defined $time;
146 6         13 return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time);
147             }
148              
149 2     2 1 639 sub sigex { return &sigexpiration; } ## historical
150              
151 2     2 1 682 sub sigin { return &siginception; } ## historical
152              
153             sub sigval {
154 2     2 1 7 my ( $self, @value ) = @_;
155 2     2   19 no integer;
  2         5  
  2         25  
156 2         7 return ( $self->{sigval} ) = map { int( 86400 * $_ ) } @value;
  2         17  
157             }
158              
159              
160             sub keytag {
161 9     9 1 1062 my ( $self, @value ) = @_;
162 9         15 for (@value) { $self->{keytag} = 0 + $_ }
  4         9  
163 9   100     41 return $self->{keytag} || 0;
164             }
165              
166              
167             sub signame {
168 6     6 1 1045 my ( $self, @value ) = @_;
169 6         11 for (@value) { $self->{signame} = Net::DNS::DomainName->new($_) }
  4         16  
170 6 100       25 return $self->{signame} ? $self->{signame}->name : undef;
171             }
172              
173              
174             sub sig {
175 8     8 1 667 my ( $self, @value ) = @_;
176 8 100       22 return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @value;
177 4         29 return $self->sigbin( MIME::Base64::decode( join "", @value ) );
178             }
179              
180              
181             sub sigbin {
182 16     16 1 32 my ( $self, @value ) = @_;
183 16         30 for (@value) { $self->{sigbin} = $_ }
  4         9  
184 16   100     108 return $self->{sigbin} || "";
185             }
186              
187              
188 6     6 1 1162 sub signature { return &sig; }
189              
190              
191             sub create {
192 1     1 1 430 unless (DNSSEC) {
193 1         150 croak qq[No "use Net::DNS::SEC" declaration in application code];
194             } else {
195             my ( $class, $rrsetref, $priv_key, %etc ) = @_;
196              
197             $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY';
198             my $RR = $rrsetref->[0];
199             croak '$rrsetref is not reference to RR array' unless ref($RR) =~ /^Net::DNS::RR/;
200              
201             # All the TTLs need to be the same in the data RRset.
202             my $ttl = $RR->ttl;
203             croak 'RRs in RRset do not have same TTL' if grep { $_->ttl != $ttl } @$rrsetref;
204              
205             my $private = ref($priv_key) ? $priv_key : Net::DNS::SEC::Private->new($priv_key);
206             croak 'unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private';
207              
208             my @label = grep { $_ ne chr(42) } $RR->{owner}->_wire; # count labels
209              
210             my $self = Net::DNS::RR->new(
211             name => $RR->name,
212             type => 'RRSIG',
213             class => 'IN',
214             ttl => $ttl,
215             typecovered => $RR->type,
216             labels => scalar @label,
217             orgttl => $ttl,
218             siginception => time(),
219             algorithm => $private->algorithm,
220             keytag => $private->keytag,
221             signame => $private->signame,
222             );
223              
224             while ( my ( $attribute, $value ) = each %etc ) {
225             $self->$attribute($value);
226             }
227              
228             $self->{sigexpiration} = $self->{siginception} + $self->{sigval}
229             unless $self->{sigexpiration};
230              
231             my $sigdata = $self->_CreateSigData($rrsetref);
232             $self->_CreateSig( $sigdata, $private );
233             return $self;
234             }
235             }
236              
237              
238             sub verify {
239              
240             # Reminder...
241              
242             # $rrsetref must be a reference to an array of RR objects.
243              
244             # $keyref is either a key object or a reference to an array of key objects.
245              
246 1     1 1 494 unless (DNSSEC) {
247 1         85 croak qq[No "use Net::DNS::SEC" declaration in application code];
248             } else {
249             my ( $self, $rrsetref, $keyref ) = @_;
250              
251             croak '$keyref argument is scalar or undefined' unless ref($keyref);
252              
253             print '$keyref argument is ', ref($keyref), "\n" if DEBUG;
254             if ( ref($keyref) eq "ARRAY" ) {
255              
256             # We will iterate over the supplied key list and
257             # return when there is a successful verification.
258             # If not, continue so that we survive key-id collision.
259              
260             print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG;
261             my @error;
262             foreach my $keyrr (@$keyref) {
263             my $result = $self->verify( $rrsetref, $keyrr );
264             return $result if $result;
265             my $error = $self->{vrfyerrstr};
266             my $keyid = $keyrr->keytag;
267             push @error, "key $keyid: $error";
268             print "key $keyid: $error\n" if DEBUG;
269             next;
270             }
271              
272             $self->{vrfyerrstr} = join "\n", @error;
273             return 0;
274              
275             } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) {
276              
277             print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG;
278              
279             } else {
280             croak join ' ', ref($keyref), 'can not be used as DNSSEC key';
281             }
282              
283              
284             $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY';
285             my $RR = $rrsetref->[0];
286             croak '$rrsetref not a reference to array of RRs' unless ref($RR) =~ /^Net::DNS::RR/;
287              
288             if (DEBUG) {
289             print "\n ---------------------- RRSIG DEBUG --------------------";
290             print "\n SIG:\t", $self->string;
291             print "\n KEY:\t", $keyref->string;
292             print "\n -------------------------------------------------------\n";
293             }
294              
295             $self->{vrfyerrstr} = '';
296             unless ( $self->algorithm == $keyref->algorithm ) {
297             $self->{vrfyerrstr} = 'algorithm does not match';
298             return 0;
299             }
300              
301             unless ( $self->keytag == $keyref->keytag ) {
302             $self->{vrfyerrstr} = 'keytag does not match';
303             return 0;
304             }
305              
306             my $sigdata = $self->_CreateSigData($rrsetref);
307             $self->_VerifySig( $sigdata, $keyref ) || return 0;
308              
309             # time to do some time checking.
310             my $t = time;
311              
312             if ( _ordered( $self->{sigexpiration}, $t ) ) {
313             $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration;
314             return 0;
315             } elsif ( _ordered( $t, $self->{siginception} ) ) {
316             $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception;
317             return 0;
318             }
319              
320             return 1;
321             }
322             } #END verify
323              
324              
325             sub vrfyerrstr {
326 2     2 1 647 my $self = shift;
327 2         8 return $self->{vrfyerrstr};
328             }
329              
330              
331             ########################################
332              
333             {
334             my @algbyname = (
335             'DELETE' => 0, # [RFC4034][RFC4398][RFC8078]
336             'RSAMD5' => 1, # [RFC3110][RFC4034]
337             'DH' => 2, # [RFC2539]
338             'DSA' => 3, # [RFC3755][RFC2536]
339             ## Reserved => 4, # [RFC6725]
340             'RSASHA1' => 5, # [RFC3110][RFC4034]
341             'DSA-NSEC3-SHA1' => 6, # [RFC5155]
342             'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155]
343             'RSASHA256' => 8, # [RFC5702]
344             ## Reserved => 9, # [RFC6725]
345             'RSASHA512' => 10, # [RFC5702]
346             ## Reserved => 11, # [RFC6725]
347             'ECC-GOST' => 12, # [RFC5933]
348             'ECDSAP256SHA256' => 13, # [RFC6605]
349             'ECDSAP384SHA384' => 14, # [RFC6605]
350             'ED25519' => 15, # [RFC8080]
351             'ED448' => 16, # [RFC8080]
352              
353             'INDIRECT' => 252, # [RFC4034]
354             'PRIVATEDNS' => 253, # [RFC4034]
355             'PRIVATEOID' => 254, # [RFC4034]
356             ## Reserved => 255, # [RFC4034]
357             );
358              
359             my %algbyval = reverse @algbyname;
360              
361             foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics
362             my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname;
363             my %algbyname = @algrehash; # work around broken cperl
364              
365             sub _algbyname {
366 8     8   13 my $arg = shift;
367 8         16 my $key = uc $arg; # synthetic key
368 8         19 $key =~ s/[\W_]//g; # strip non-alphanumerics
369 8         16 my $val = $algbyname{$key};
370 8 100       33 return $val if defined $val;
371 2 100       239 return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg];
372             }
373              
374             sub _algbyval {
375 3     3   6 my $value = shift;
376 3   100     22 return $algbyval{$value} || return $value;
377             }
378             }
379              
380              
381             sub _CreateSigData {
382              
383             # This method creates the data string that will be signed.
384             # See RFC4034(6) and RFC6840(5.1) on how this string is constructed
385              
386             # This method is called by the method that creates a signature
387             # and by the method that verifies the signature. It is assumed
388             # that the creation method has checked that all the TTLs are
389             # the same for the rrsetref and that sig->orgttl has been set
390             # to the TTL of the data. This method will set the datarr->ttl
391             # to the sig->orgttl for all the RR in the rrsetref.
392              
393 1     1   439 if (DNSSEC) {
394             my ( $self, $rrsetref ) = @_;
395              
396             print "_CreateSigData\n" if DEBUG;
397              
398             my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->canonical;
399             print "\npreamble\t", unpack( 'H*', $sigdata ), "\n" if DEBUG;
400              
401             my $owner = $self->{owner}; # create wildcard domain name
402             my $limit = $self->{labels};
403             my @label = $owner->_wire;
404             shift @label while scalar @label > $limit;
405             my $wild = bless {label => \@label}, ref($owner); # DIY to avoid wrecking name cache
406             my $suffix = $wild->canonical;
407             unshift @label, chr(42); # asterisk
408              
409             my @RR = map { bless( {%$_}, ref($_) ) } @$rrsetref; # shallow RR clone
410             my $rr = $RR[0];
411             my $class = $rr->class;
412             my $type = $rr->type;
413             my $ttl = $self->orgttl;
414              
415             my %table;
416             foreach my $RR (@RR) {
417             my $ident = $RR->{owner}->canonical;
418             my $match = substr $ident, -length($suffix);
419             croak 'RRs in RRset have different NAMEs' if $match ne $suffix;
420             croak 'RRs in RRset have different TYPEs' if $type ne $RR->type;
421             croak 'RRs in RRset have different CLASS' if $class ne $RR->class;
422             $RR->ttl($ttl); # reset TTL
423              
424             my $offset = 10 + length($suffix); # RDATA offset
425             if ( $ident ne $match ) {
426             $RR->{owner} = $wild;
427             $offset += 2;
428             print "\nsubstituting wildcard name: ", $RR->name if DEBUG;
429             }
430              
431             # For sorting we create a hash table of canonical data keyed on RDATA
432             my $canonical = $RR->canonical;
433             $table{substr $canonical, $offset} = $canonical;
434             }
435              
436             $sigdata = join '', $sigdata, map { $table{$_} } sort keys %table;
437              
438             if (DEBUG) {
439             my $i = 0;
440             foreach my $rdata ( sort keys %table ) {
441             print "\n>>> ", $i++, "\tRDATA:\t", unpack 'H*', $rdata;
442             print "\nRR: ", unpack( 'H*', $table{$rdata} ), "\n";
443             }
444             print "\n sigdata:\t", unpack( 'H*', $sigdata ), "\n";
445             }
446              
447             return $sigdata;
448             }
449             }
450              
451              
452             sub _CreateSig {
453 1     1   35 if (DNSSEC) {
454             my ( $self, @argument ) = @_;
455              
456             my $algorithm = $self->algorithm;
457             my $class = $DNSSEC_siggen{$algorithm};
458              
459             return eval {
460             die "algorithm $algorithm not supported\n" unless $class;
461             $self->sigbin( $class->sign(@argument) );
462             } || return croak "${@}signature generation failed";
463             }
464             }
465              
466              
467             sub _VerifySig {
468 1     1   431 if (DNSSEC) {
469             my ( $self, @argument ) = @_;
470              
471             my $algorithm = $self->algorithm;
472             my $class = $DNSSEC_verify{$algorithm};
473              
474             my $retval = eval {
475             die "algorithm $algorithm not supported\n" unless $class;
476             $class->verify( @argument, $self->sigbin );
477             };
478              
479             unless ($retval) {
480             $self->{vrfyerrstr} = "${@}signature verification failed";
481             print "\n", $self->{vrfyerrstr}, "\n" if DEBUG;
482             return 0;
483             }
484              
485             # uncoverable branch true # bug in Net::DNS::SEC or dependencies
486             croak "unknown error in $class->verify" unless $retval == 1;
487             print "\nalgorithm $algorithm verification successful\n" if DEBUG;
488             return 1;
489             }
490             }
491              
492              
493             sub _ordered() { ## irreflexive 32-bit partial ordering
494 12     12   667 my ( $n1, $n2 ) = @_;
495              
496 12 100       33 return 0 unless defined $n2; # ( any, undef )
497 10 100       24 return 1 unless defined $n1; # ( undef, any )
498              
499             # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished
500 2     2   4716 use integer;
  2         5  
  2         10  
501 9 100       21 if ( $n2 < 0 ) { # fold, leaving $n2 non-negative
502 3         6 $n1 = ( $n1 & 0xFFFFFFFF ) ^ 0x80000000; # -2**31 <= $n1 < 2**32
503 3         6 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31
504             }
505              
506 9 100       46 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) );
507             }
508              
509              
510             my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 );
511             my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 );
512             my $y2082 = $y2026 << 1;
513             my $y2054 = $y2082 - $y1998;
514             my $m2026 = int( 0x80000000 - $y2026 );
515             my $m2054 = int( 0x80000000 - $y2054 );
516             my $t2082 = int( $y2082 & 0x7FFFFFFF );
517             my $t2100 = 1960058752;
518              
519             sub _string2time { ## parse time specification string
520 16     16   5145 my $arg = shift;
521 16 100       55 return int($arg) if length($arg) < 12;
522 15         73 my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00';
523 15 100       49 if ( $arg lt '20380119031408' ) { # calendar folding
    100          
524 10 100       39 return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026;
525 1         5 return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026;
526             } elsif ( $y > 2082 ) {
527 4         16 my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); # expunge 29 Feb 2100
528 4 100       151 return $z < 1456790400 ? $z + $y2054 : $z + $y2054 - 86400;
529             }
530 1         6 return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998;
531             }
532              
533              
534             sub _time2string { ## format time specification string
535 26     26   4506 my $arg = shift;
536 26         49 my $ls31 = int( $arg & 0x7FFFFFFF );
537 26 100       61 if ( $arg & 0x80000000 ) {
    100          
538              
539 10 100       24 if ( $ls31 > $t2082 ) {
540 8 100       18 $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100
541 8         41 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] );
542 8         53 return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms;
543             }
544              
545 2         11 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] );
546 2         14 return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms;
547              
548              
549             } elsif ( $ls31 > $y2026 ) {
550 2         12 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] );
551 2         14 return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms;
552             }
553              
554 14         61 my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] );
555 14         108 return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms;
556             }
557              
558             ########################################
559              
560              
561             1;
562             __END__