1package Net::DNS::RR::SVCB; 2 3use strict; 4use warnings; 5our $VERSION = (qw$Id: SVCB.pm 1845 2021-07-14 15:30:16Z willem $)[2]; 6 7use base qw(Net::DNS::RR); 8 9 10=head1 NAME 11 12Net::DNS::RR::SVCB - DNS SVCB resource record 13 14=cut 15 16use integer; 17 18use Carp; 19use MIME::Base64; 20use Net::DNS::DomainName; 21use Net::DNS::RR::A; 22use Net::DNS::RR::AAAA; 23use Net::DNS::Text; 24 25 26my %keybyname = ( 27 mandatory => 'key0', 28 alpn => 'key1', 29 'no-default-alpn' => 'key2', 30 port => 'key3', 31 ipv4hint => 'key4', 32 ech => 'key5', 33 ipv6hint => 'key6', 34 ); 35 36 37sub _decode_rdata { ## decode rdata from wire-format octet string 38 my $self = shift; 39 my ( $data, $offset ) = @_; 40 41 my $rdata = substr $$data, $offset, $self->{rdlength}; 42 $self->{SvcPriority} = unpack( 'n', $rdata ); 43 44 my $index; 45 ( $self->{TargetName}, $index ) = Net::DNS::DomainName->decode( \$rdata, 2 ); 46 47 my $params = $self->{SvcParams} = []; 48 my $limit = length($rdata) - 3; 49 while ( $index < $limit ) { 50 my ( $key, $size ) = unpack( "\@$index n2", $rdata ); 51 push @$params, ( $key, substr $rdata, $index + 4, $size ); 52 $index += ( $size + 4 ); 53 } 54 die $self->type . ': corrupt RDATA' unless $index == length($rdata); 55 return; 56} 57 58 59sub _encode_rdata { ## encode rdata as wire-format octet string 60 my $self = shift; 61 62 my @packed = pack 'n a*', $self->{SvcPriority}, $self->{TargetName}->encode; 63 my $params = $self->{SvcParams} || []; 64 my @params = @$params; 65 while (@params) { 66 my $key = shift @params; 67 my $val = shift @params; 68 push @packed, pack( 'n2a*', $key, length($val), $val ); 69 } 70 return join '', @packed; 71} 72 73 74sub _format_rdata { ## format rdata portion of RR string. 75 my $self = shift; 76 77 my $priority = $self->{SvcPriority}; 78 my $params = $self->{SvcParams} || []; 79 return ( $priority, $self->{TargetName}->string ) unless scalar @$params; 80 81 my @rdata = unpack 'H4', pack 'n', $priority; 82 my $target = $self->{TargetName}->encode(); 83 my $length = 2 + length $target; 84 my @target = split /(\S{32})/, unpack 'H*', $target; 85 push @rdata, $length > 18 ? "\t; $priority\n" : (), @target; 86 push @rdata, join '', "\t; ", $self->{TargetName}->string, "\n" if $length > 3; 87 88 my @params = @$params; 89 while (@params) { 90 my $key = shift @params; 91 my $val = shift @params; 92 push @rdata, "\n"; 93 push @rdata, "; key$key=...\n" if $key > 15; 94 push @rdata, unpack 'H4H4', pack( 'n2', $key, length $val ); 95 push @rdata, split /(\S{32})/, unpack 'H*', $val; 96 $length += 4 + length $val; 97 } 98 return ( "\\# $length", @rdata ); 99} 100 101 102sub _parse_rdata { ## populate RR from rdata in argument list 103 my $self = shift; 104 105 $self->svcpriority(shift); 106 $self->targetname(shift); 107 108 local $SIG{__WARN__} = sub { die @_ }; 109 while ( my $svcparam = shift ) { 110 for ($svcparam) { 111 my @value; 112 if (/^key\d+=(.*)$/i) { 113 push @value, length($1) ? $1 : shift; 114 } elsif (/=(.*)$/) { 115 local $_ = length($1) ? $1 : shift; 116 s/^(["'])(.*)\1$/$2/; # strip paired quotes 117 s/\\,/\\044/g; # disguise escaped comma 118 push @value, split /,/; 119 } else { 120 push @value, '' unless $keybyname{lc $_}; # empty keyNNN 121 } 122 123 s/[-]/_/g; # extract identifier 124 m/^([^=]+)/; 125 $self->$1(@value); 126 } 127 } 128 return; 129} 130 131 132sub _post_parse { ## parser post processing 133 my $self = shift; 134 135 my $params = $self->{SvcParams} || return; 136 my %params = @$params; 137 $self->key0(undef); # ruse to force sorting of SvcParams 138 if ( defined $params{0} ) { 139 my %unique; 140 foreach ( grep { !$unique{$_}++ } unpack 'n*', $params{0} ) { 141 croak( $self->type . qq[: unexpected "key0" in mandatory list] ) if $unique{0}; 142 croak( $self->type . qq[: duplicate "key$_" in mandatory list] ) if --$unique{$_}; 143 croak( $self->type . qq[: mandatory "key$_" not present] ) unless defined $params{$_}; 144 } 145 $self->mandatory( keys %unique ); # restore mandatory key list 146 } 147 croak( $self->type . qq[: expected alpn="..." not present] ) if defined( $params{2} ) and !$params{1}; 148 return; 149} 150 151 152sub _defaults { ## specify RR attribute default values 153 my $self = shift; 154 155 $self->_parse_rdata(qw(0 .)); 156 return; 157} 158 159 160sub svcpriority { 161 my $self = shift; # uncoverable pod 162 163 $self->{SvcPriority} = 0 + shift if scalar @_; 164 return $self->{SvcPriority} || 0; 165} 166 167 168sub targetname { 169 my $self = shift; # uncoverable pod 170 171 $self->{TargetName} = Net::DNS::DomainName->new(shift) if scalar @_; 172 173 my $target = $self->{TargetName} ? $self->{TargetName}->name : return; 174 return $target unless $self->{SvcPriority}; 175 return ( $target eq '.' ) ? $self->owner : $target; 176} 177 178 179######################################## 180 181 182sub _presentation { ## render octet string(s) in presentation format 183 return () unless scalar @_; 184 my $raw = join '', @_; 185 my $txt = Net::DNS::Text->decode( \$raw, 0, length($raw) ); 186 return map { s/ /\\032/g; s/,/\\044/g; $_ } $txt->string; 187} 188 189sub _base64 { 190 return _presentation( map { MIME::Base64::decode($_) } @_ ); 191} 192 193sub _integer16 { 194 return _presentation( map { pack( 'n', $_ ) } @_ ); 195} 196 197sub _ipv4 { 198 return _presentation( map { Net::DNS::RR::A::address( {}, $_ ) } @_ ); 199} 200 201sub _ipv6 { 202 return _presentation( map { Net::DNS::RR::AAAA::address( {}, $_ ) } @_ ); 203} 204 205sub _string { 206 return _presentation( map { Net::DNS::Text->new($_)->encode() } @_ ); 207} 208 209 210sub mandatory { ## mandatory=key1,port,... 211 my $self = shift; 212 my @list = map { $keybyname{lc $_} || $_ } map { split /,/ } @_; 213 my @keys = map { /(\d+)$/ ? $1 : croak( $self->type . qq[: unexpected "$_"] ) } @list; 214 return $self->key0( _integer16( sort { $a <=> $b } @keys ) ); 215} 216 217sub alpn { ## alpn=h3,h2,... 218 my $self = shift; 219 220 ### tolerate unnecessary double-escape nonsense in draft-ietf-dnsop-svcb-https ### 221 my @sanitized = map { s/\\092,/\\044/g; s/\\092\\092/\\092/g; split /,/ } join ',', @_; 222 return $self->key1( scalar(@_) ? _string(@sanitized) : () ); 223} 224 225sub no_default_alpn { ## no-default-alpn 226 my $self = shift; # uncoverable pod 227 return $self->key2( ( defined(wantarray) ? @_ : '' ), @_ ); 228} 229 230sub port { ## port=1234 231 my $self = shift; 232 return $self->key3( map { _integer16($_) } @_ ); 233} 234 235sub ipv4hint { ## ipv4hint=192.0.2.1,... 236 my $self = shift; 237 return $self->key4( _ipv4(@_) ); 238} 239 240sub ech { ## ech=base64string 241 my $self = shift; 242 return $self->key5( map { _base64($_) } @_ ); 243} 244 245sub ipv6hint { ## ipv6hint=2001:DB8::1,... 246 my $self = shift; 247 return $self->key6( _ipv6(@_) ); 248} 249 250 251our $AUTOLOAD; 252 253sub AUTOLOAD { ## Dynamic constructor/accessor methods 254 my $self = shift; 255 256 my ($method) = reverse split /::/, $AUTOLOAD; 257 258 my $default = join '::', 'SUPER', $method; 259 return $self->$default(@_) unless $method =~ /^key[0]*(\d+)$/i; 260 my $key = $1; 261 262 my $params = $self->{SvcParams} || []; 263 my %params = @$params; 264 265 if ( scalar @_ ) { 266 my $arg = shift; # keyNN($value); 267 delete $params{$key} unless defined $arg; 268 croak( $self->type . qq[: duplicate SvcParam "key$key"] ) if defined $params{$key}; 269 $params{$key} = Net::DNS::Text->new("$arg")->raw if defined $arg; 270 $self->{SvcParams} = [map { ( $_, $params{$_} ) } sort { $a <=> $b } keys %params]; 271 croak( $self->type . qq[: unexpected number of values for "key$key"] ) if scalar @_; 272 } else { 273 croak( $self->type . qq[: no value specified for "key$key"] ) unless defined wantarray; 274 } 275 276 my $value = $params{$key}; 277 return defined($value) ? _presentation($value) : $value; 278} 279 280 2811; 282__END__ 283 284 285=head1 SYNOPSIS 286 287 use Net::DNS; 288 $rr = Net::DNS::RR->new('name HTTPS SvcPriority TargetName alpn=h3,...'); 289 290=head1 DESCRIPTION 291 292DNS Service Binding (SVCB) resource record 293 294Service binding and parameter specification 295via the DNS (SVCB and HTTPS RRs) 296 297=head1 METHODS 298 299The available methods are those inherited from the base class augmented 300by the type-specific methods defined in this package. 301 302Use of undocumented package features or direct access to internal data 303structures is discouraged and could result in program termination or 304other unpredictable behaviour. 305 306 307=head2 SvcPriority 308 309 $svcpriority = $rr->svcpriority; 310 $rr->svcpriority( $svcpriority ); 311 312The priority of this record 313(relative to others, with lower values preferred). 314A value of 0 indicates AliasMode. 315 316=head2 TargetName 317 318 $rr->targetname( $targetname ); 319 $effecivetarget = $rr->targetname; 320 321The domain name of either the alias target (for AliasMode) 322or the alternative endpoint (for ServiceMode). 323 324For AliasMode SVCB RRs, a TargetName of "." indicates that the 325service is not available or does not exist. 326 327For ServiceMode SVCB RRs, a TargetName of "." indicates that the 328owner name of this record must be used as the effective TargetName. 329 330=head2 mandatory, alpn, no-default-alpn, port, ipv4hint, ech, ipv6hint 331 332 $rr = Net::DNS::RR->new( 'svc.example. SVCB 1 svc.example. port=1234' ); 333 334 $rr->port(1234); 335 $string = $rr->port(); # \004\210 336 $rr->key3($string); 337 338Constructor methods for mnemonic SvcParams defined in draft-ietf-dnsop-svcb-https. 339When invoked without arguments, the methods return the presentation format 340value for the underlying key. 341The behaviour with undefined arguments is not specified. 342 343=head2 keyNN 344 345 $keynn = $rr->keyNN; 346 $rr->keyNN( $keynn ); 347 $rr->keyNN( undef ); 348 349Generic constructor and accessor methods for SvcParams. 350The key index NN is a decimal integer in the range 0 .. 65534. 351The method argument and returned value are both presentation format strings. 352The method returns the undefined value if the key is not present. 353The specified key will be deleted if the value is undefined. 354 355 356=head1 COPYRIGHT 357 358Copyright (c)2020-2021 Dick Franks. 359 360All rights reserved. 361 362Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. 363 364 365=head1 LICENSE 366 367Permission to use, copy, modify, and distribute this software and its 368documentation for any purpose and without fee is hereby granted, provided 369that the above copyright notice appear in all copies and that both that 370copyright notice and this permission notice appear in supporting 371documentation, and that the name of the author not be used in advertising 372or publicity pertaining to distribution of the software without specific 373prior written permission. 374 375THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 376IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 377FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 378THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 379LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 380FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 381DEALINGS IN THE SOFTWARE. 382 383 384=head1 SEE ALSO 385 386L<perl>, L<Net::DNS>, L<Net::DNS::RR>, draft-ietf-dnsop-svcb-https 387 388=cut 389