# HG changeset patch
# User Matthias Förste <foerste@schlittermann.de>
# Date 1661781878 -7200
# Node ID 7e4d3e9075c6e6724c165674acb09cb6617c6232
# Parent  0b0e57cd2ce933a9ef52cc42a5016c26780db8b8
[savepoint]

diff -r 0b0e57cd2ce9 -r 7e4d3e9075c6 dnsproxy
--- a/dnsproxy	Mon Aug 26 14:20:16 2013 +0200
+++ b/dnsproxy	Mon Aug 29 16:04:38 2022 +0200
@@ -30,7 +30,8 @@
 
 my $opts = {
     listen => ['127.0.0.2'],
-    port   => 53
+    port   => 53,
+    tcp_timeout => 30,
 };
 
 GetOptions(
@@ -50,11 +51,12 @@
 my $resolver = Net::DNS::Resolver->new;
 my %args     = (
     host         => $opts->{listen},
-    port         => "$opts->{port}/udp",
+    port         => [ "$opts->{port}/udp", "$opts->{port}/tcp" ],
     log_file     => 'Sys::Syslog',
     syslog_ident => $ME,
     pid_file     => "/var/run/$ME.pid",
-    background   => 1
+    background   => 1,
+    no_client_stdout => 1
 );
 $args{log_level} = $opts->{verbose} if defined $opts->{verbose};
 dnsproxy->run(%args);
@@ -64,32 +66,90 @@
     my $self = shift;
     my $prop = $self->{server};
 
-    die 'Sorry, udp only!' unless $prop->{udp_true};
+    my $data;
+    if ($prop->{udp_true}) {
+        $data = $prop->{udp_data};
+    # assuming tcp
+    } else {
+
+        #use Socket qw(IPPROTO_TCP);
+        use Fcntl qw(O_NONBLOCK);
 
-    my ($q, $e) = Net::DNS::Packet->new(\$prop->{udp_data});
-    die "Sorry: $e" unless defined $q;
+        $prop->{client}->sockopt(O_NONBLOCK, 0)
+            or die "Can't sockopt: $!";
+        $prop->{client}->recv($data, 0)
+            or die "Can't recv: $!";
+        my $l = unpack 'n', substr($data, 0, 2);
+        substr($data, 0, 2) = '';
+        die "Incomplete data" unless $l = length $data;
+#        eval {
+#
+#            local $SIG{'ALRM'} = sub { die "Timed Out!\n" };
+#            my $timeout = 30; # give the client 30 seconds to send its data
+#
+#            my $previous_alarm = alarm($opts->{tcp_timeout});
+#            # first 2 bytes are the length for tcp queries
+#$self->log(1, __LINE__);
+#            my $r = read STDIN, my $l, 2;
+#$self->log(1, __LINE__);
+#            die "Error reading data: $!" unless defined $r and $r == 2;
+#            die "No data received" unless $r;
+#$self->log(1, __LINE__);
+#            my $len = unpack('n', $l);
+#            $r = read STDIN, $data, unpack('n', $len);
+#$self->log(1, __LINE__);
+#            die "Error reading data: $!" unless defined $r and $r == $len;
+#            die "No data received" unless $r;
+#$self->log(1, "$r/$len");
+#$self->log(1, __LINE__);
+#            alarm($previous_alarm);
+#
+#        };
+#
+#        if ($@) {
+#            $self->log(1, $@);
+#            print STDERR $@;
+#            return;
+#        }
+#
+    }
 
-    my $r;
-    my @q = $q->question;
-    die 'Sorry, single question only!' unless @q == 1;
+    my ($request, $e) = Net::DNS::Packet->new(\$data);
+    unless (defined $request) {
+        $self->log(1, "Sorry: $e");
+        return;
+    }
+
+    my $reply;
+    my @q = $request->question;
+    unless (@q == 1) {
+        $self->log(1, "Sorry: $e");
+        return;
+    }
 
     # we don't know when shell may fix their dns servers so we answer for them
     if ($q[0]->qtype eq 'AAAA' and $q[0]->qname =~ /(^|\.)shell\.com/) {
-        $r = $q;
-        $r->header->qr(1);
-        $r->header->ra(1);
+        $reply = $request;
+        $reply->header->qr(1);
+        $reply->header->ra(1);
 
         # everything else is just forwarded to our regular resolver
     } else {
-        $r = $resolver->send($q);
+        $reply = $resolver->send($request);
     }
 
     # trigger parsing of nonquestion sections because 'data' would return only
     # the question section(s) otherwise (TODO: Bug report against
     # Net::DNS::Packet)
-    $r->string;
+    $reply->string;
 
-    $prop->{client}->send($r->data, 0);
+    if ($prop->{udp_true}) {
+        $prop->{client}->send($reply->data, 0);
+    # assuming tcp
+    } else {
+        my $d = $reply->data;
+        print pack('n', length $d), $d;
+    }
 
 }