# HG changeset patch # User Matthias Förste # Date 1377515825 -7200 # Node ID b888e5e9ae4df45f0395069eb3ef7d19d875a35a # Parent a94c51554e8d9da78cfbcf98ae97dcb1f4ce9720 rewritten to use "Net::Server" because we need a forking server diff -r a94c51554e8d -r b888e5e9ae4d dnsproxy --- a/dnsproxy Mon Aug 26 11:46:00 2013 +0200 +++ b/dnsproxy Mon Aug 26 13:17:05 2013 +0200 @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w -T # Copyright (C) 2013 Matthias Förste # @@ -23,6 +23,8 @@ use strict; use warnings; +package dnsproxy; + use Getopt::Long; use Pod::Usage; @@ -42,45 +44,56 @@ }, "l|listen=s" => $opts->{listen}, "p|port=i" => \$opts->{port}, - "v|verbose" => \$opts->{verbose} + "v|verbose=i" => \$opts->{verbose} ) or pod2usage(); -#die $opts->{port}; +use File::Basename; +my $ME = basename $0; + +use Net::DNS::Resolver; +use Net::DNS::Packet; +use base qw(Net::Server::Fork); -use Net::DNS::Nameserver; -use Net::DNS::Resolver; +my $resolver = Net::DNS::Resolver->new; +my %args = ( + host => $opts->{listen}, + port => "$opts->{port}/udp", + log_file => 'Sys::Syslog', + syslog_ident => $ME +); +$args{log_level} = $opts->{verbose} if defined $opts->{verbose}; +dnsproxy->run(%args); + +sub process_request { -my $res = Net::DNS::Resolver->new; -my $ns = Net::DNS::Nameserver->new( - LocalAddr => $opts->{listen}, - LocalPort => $opts->{port}, - ReplyHandler => \&reply_handler, - Verbose => $opts->{verbose}, - Truncate => 0, -) or die; -$ns->main_loop; + my $self = shift; + my $prop = $self->{server}; + + die 'Sorry, udp only!' unless $prop->{udp_true}; + + my ($q, $e) = Net::DNS::Packet->new(\$prop->{udp_data}); + die "Sorry: $e" unless defined $q; -sub reply_handler { + my $r; + my @q = $q->question; + die 'Sorry, single question only!' unless @q == 1; - my ($qname, $qclass, $qtype, $peerhost, $query, $conn) = @_; - my ($rcode, @ans, @auth, @add); - - if ($opts->{verbose}) { - print "Received query from $peerhost to ". $conn->{"sockhost"}. "\n"; - $query->print; + # 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); + # everything else is just forwarded to our regular resolver + } else { + $r = $resolver->send($q); } - # we don't know when shell may fix their dns servers so we answer for them - return 'NOERROR' if ($qtype eq 'AAAA' and $qname =~ /(^|\.)shell\.com/); + # trigger parsing of nonquestion sections because 'data' would return only + # the question section(s) otherwise (TODO: Bug report against + # Net::DNS::Packet) + $r->string; - # everything else is just forwarded to our regular resolver - my $p = $res->send($query); - return ( - $p->header->rcode, - [$p->answer], - [$p->authority], - [$p->additional] - ); + $prop->{client}->send($r->data, 0); } @@ -96,6 +109,7 @@ dnsproxy [-l|--listen address] [-p|--port port] + [-v|--verbose level] dnsproxy -m|--man -h|--help @@ -131,6 +145,10 @@ Listen on port . The default is 53. +=item B<-v|--verbose> I + +Verbosity level. Passed to Net::Server. + =back =head1 AUTHOR