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