File Coverage

blib/lib/Net/DNS/RR/SIG.pm
Criterion Covered Total %
statement 171 171 100.0
branch 50 50 100.0
condition 14 14 100.0
subroutine 44 44 100.0
pod 14 17 100.0
total 293 296 100.0


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