| Subject: | Net::DNS::Nameserver doesn't truncate long UDP replies [PATCH] |
Net::DNS::Nameserver never attempts to apply the UDP truncation logic
required by RFC 1035 sections 4.2.1 and 6.2.
It's impossible for the ReplyHandler to work around this, because it
never has access to the socket on which the query was received, and so
can't determine whether it's a datagram or stream socket.
The attached patch against SVN r715 contains:
- Tests for the desired truncation behaviour, with both standard
512-byte UDP packets and extended 1024-byte UDP packets (using an EDNS0
OPT record)
- Changes to lib/Net/DNS/Nameserver.pm to truncate oversized responses;
the tests fail without these changes, and pass with them
Summary of my perl5 (revision 5 version 8 subversion 8) configuration:
Platform:
osname=linux, osvers=2.6.15.7, archname=i486-linux-gnu-thread-multi
uname='linux terranova 2.6.15.7 #1 smp thu jul 12 14:27:56 utc 2007
i686 gnulinux '
config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN
-Dcccdlflags=-fPIC -Darchname=i486-linux-gnu -Dprefix=/usr
-Dprivlib=/usr/share/perl/5.8 -Darchlib=/usr/lib/perl/5.8
-Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5
-Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local
-Dsitelib=/usr/local/share/perl/5.8.8
-Dsitearch=/usr/local/lib/perl/5.8.8 -Dman1dir=/usr/share/man/man1
-Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1
-Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl
-Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Uusesfio -Uusenm
-Duseshrplib -Dlibperl=libperl.so.5.8.8 -Dd_dosuid -des'
hint=recommended, useposix=true, d_sigaction=define
usethreads=define use5005threads=undef useithreads=define
usemultiplicity=define
useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
use64bitint=undef use64bitall=undef uselongdouble=undef
usemymalloc=n, bincompat5005=undef
Compiler:
cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS
-DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-O2',
cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBIAN
-fno-strict-aliasing -pipe -I/usr/local/include'
ccversion='', gccversion='4.1.3 20070929 (prerelease) (Ubuntu
4.1.2-16ubuntu2)', gccosandvers=''
intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t',
lseeksize=8
alignbytes=4, prototype=define
Linker and Libraries:
ld='cc', ldflags =' -L/usr/local/lib'
libpth=/usr/local/lib /lib /usr/lib
libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt
perllibs=-ldl -lm -lpthread -lc -lcrypt
libc=/lib/libc-2.6.1.so, so=so, useshrplib=true,
libperl=libperl.so.5.8.8
gnulibc_version='2.6.1'
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
cccdlflags='-fPIC', lddlflags='-shared -L/usr/local/lib'
Characteristics of this binary (from libperl):
Compile-time options: MULTIPLICITY PERL_IMPLICIT_CONTEXT
PERL_MALLOC_WRAP THREADS_HAVE_PIDS USE_ITHREADS
USE_LARGE_FILES USE_PERLIO USE_REENTRANT_API
Built under linux
Compiled at Dec 4 2007 08:56:39
@INC:
/etc/perl
/usr/local/lib/perl/5.8.8
/usr/local/share/perl/5.8.8
/usr/lib/perl5
/usr/share/perl5
/usr/lib/perl/5.8
/usr/share/perl/5.8
/usr/local/lib/site_perl
.
| Subject: | udp_truncation.diff |
Index: lib/Net/DNS/Nameserver.pm
===================================================================
--- lib/Net/DNS/Nameserver.pm (revision 715)
+++ lib/Net/DNS/Nameserver.pm (working copy)
@@ -355,6 +355,20 @@
my $reply = $self->make_reply($query, $peerhost) || return;
my $reply_data = $reply->data;
+ my $max_len = $self->max_udp_len($query);
+ if (length $reply_data > $max_len) {
+ $reply->header->tc(1);
+ my @sections = qw<additional authority answer question>;
+ while (@sections) {
+ if (!$reply->pop($sections[0])) {
+ shift @sections;
+ next;
+ }
+ $reply_data = $reply->data;
+ last if length $reply_data <= $max_len;
+ }
+ }
+
local $| = 1 if $self->{"Verbose"};
print "Writing response - " if $self->{"Verbose"};
@@ -367,6 +381,17 @@
}
+sub max_udp_len {
+ my ($self, $query) = @_;
+
+ for my $rr ($query->additional) {
+ return $rr->size if $rr->type eq 'OPT';
+ }
+
+ return 512;
+}
+
+
sub get_open_tcp {
my $self=shift;
return keys %{$self->{"_tcp"}};
Index: t/13-udp-trunc.t
===================================================================
--- t/13-udp-trunc.t (revision 0)
+++ t/13-udp-trunc.t (revision 0)
@@ -0,0 +1,121 @@
+# $Id$ -*- perl
+
+use Test::More tests => 31;
+use strict;
+
+my $ZONE = 'example.com';
+
+use_ok('Net::DNS::Nameserver');
+
+{
+ my @full_response;
+ my $ns = Net::DNS::Nameserver->new(
+ LocalPort => 8053,
+ ReplyHandler => sub { NOERROR => @full_response },
+ );
+ for (trad_query(), edns_query()) {
+ my ($query, $size) = @$_;
+ for my $n (1, 5, 10, 50, 200) {
+ @full_response = make_response($n);
+ my $socket = Mock::UDP->new($query->data);
+ $ns->udp_connection($socket);
+ my $reply_data = $socket->output;
+ cmp_ok(length $reply_data, '<=', $size,
+ "UDP-$size reply for $n A records short enough");
+ my $reply = Net::DNS::Packet->new(\$reply_data);
+ ok($reply, "found UDP-$size reply for $n A records");
+ my $got = reply_records($reply);
+ my $expected = response_records($query, @full_response);
+ ok(is_prefix($reply->header->tc, $got, $expected),
+ "UDP-$size reply for $n A records complete or sanely truncated");
+ }
+ }
+}
+
+sub trad_query {
+ return [Net::DNS::Packet->new($ZONE), 512];
+}
+
+sub edns_query {
+ my $size = 1024;
+ my $edns_rr = Net::DNS::RR->new(type => 'OPT', class => $size, name => '');
+ my $query = Net::DNS::Packet->new($ZONE);
+ $query->push(additional => $edns_rr);
+ return [$query, $size];
+}
+
+sub reply_records {
+ my ($reply) = @_;
+ my @records;
+ for my $section (qw<question answer authority additional>) {
+ push @records, map { [$section => $_] } $reply->$section;
+ }
+ return \@records;
+}
+
+sub response_records {
+ my ($query, @response) = @_;
+ unshift @response, [$query->question];
+ my @records;
+ for my $section (qw<question answer authority additional>) {
+ push @records, map { [$section => $_] } @{ shift @response };
+ }
+ return \@records;
+}
+
+sub is_prefix {
+ my ($truncated, $got_list, $expected_list) = @_;
+ die 'TEST BUG: no records expected' if !@$expected_list;
+ if (@$got_list > @$expected_list) {
+ diag("Most peculiar: got too many records");
+ return 0;
+ }
+ for (;;) {
+ return !$truncated == !@$expected_list if !@$got_list;
+ my $got = shift @$got_list;
+ my $expected = shift @$expected_list;
+ my ($got_s, $expected_s) = map { $_->[1]->string } $got, $expected;
+ next if $got->[0] eq $expected->[0] && $got_s eq $expected_s;
+ if ($got->[0] ne $expected->[0] || $got_s ne $expected_s) {
+ diag("Got[$got->[0] $got_s] Expected[$expected->[0] $expected_s]");
+ return 0;
+ }
+ }
+}
+
+sub make_response {
+ my ($n) = @_;
+ my @ans = map { Net::DNS::RR->new("$ZONE 9 IN A 10.0.0.$_") } 1 .. $n;
+ my @auth = map { Net::DNS::RR->new("$ZONE 9 IN NS ns$_.$ZONE") } 1 .. 4;
+ my @add = map { Net::DNS::RR->new("ns$_.$ZONE 9 IN A 10.0.1.$_") } 1 .. 4;
+ return \@ans, \@auth, \@add;
+}
+
+{
+ package Mock::UDP;
+
+ sub new {
+ my ($class, $data) = @_;
+ return bless {
+ input => $data,
+ output => '',
+ }, $class;
+ }
+
+ sub peerhost { '127.0.0.1' }
+ sub peerport { 65534 }
+ sub output { $_[0]{output} }
+
+ sub recv {
+ my ($self, $buf, $len) = @_;
+ return if $self->{input} eq '';
+ my $data = substr $self->{input}, 0, $len, '';
+ $_[1] = $data;
+ }
+
+ sub send {
+ my ($self, $data) = @_;
+ $self->{output} .= $data;
+ 1;
+ }
+}