[Author Prev][Author Next][Thread Prev][Thread Next][Author Index][Thread Index]

Re: The State of the DNS and Tor Union (also: a DNS UDP - >TCP shim)



On Mon, Jul 5, 2010 at 6:49 PM, Jacob Appelbaum <jacob@xxxxxxxxxxxxx> wrote:
> ...
> I haven't seen a PERL version of the program - do you have a link to the
> source?

this is the only copy i have on hand. i believe there is an updated
version in bsd ports archive (no longer in current mirrors).

best regards,
#!/usr/bin/perl
#
# dns-proxy-tor
#
# This script has been dedicated to the public domain.
# See LICENSE file included with this distribution for the dedication.
#

use strict;
use warnings;

our $VERSION = '0.0.6';

{
  package Log;

  use strict;
  use warnings;

  use constant INFO   => 0;
  use constant DEBUG  => 1;

  my @Levels = qw/INFO DEBUG/;
  my @Attributes = qw/level handle/;

  our %Log = (level => 1);
  our $Err;

  sub _self {
    my $class = __PACKAGE__;
    no strict 'refs';
    return \%$class;
  }

  sub init {
    my $self = shift->_self;
    %$self = @_;
    if (not $self->{handle} and not open $self->{handle}, '>>', $self->{file}) {
      $Err = "Can't open log file $self->{file}: $!\n";
      return;
    }
    select( (select($self->{handle}), $| = 1)[0] );
    return 1;
  }

  sub close {
    my $self = shift->_self;
    close $self->{handle};
  }

  for my $attribute (@Attributes) {
    no strict 'refs';
    *$attribute = sub {
      use strict 'refs';
      my $self = shift->_self;
      $self->{$attribute} = shift if @_;
      return $self->{$attribute};
    };
  }

  for my $level (@Levels) {
    no strict 'refs';
    *{lc $level} = sub {
      my $self = shift->_self;
      return unless $self->{level} >= &$level;
      use strict 'refs';
      my $fh = $self->{handle};
      printf $fh @_;
    };
  }

  1;
}

{
  package DNS::Session;

  use strict;
  use warnings;

  use Socket;

  use constant SERVFAIL => 0x8102;
  use constant NOERROR  => 0x8100;

  use constant TYPE_A   => 1;
  use constant CLASS_IN => 1;
  use constant NAME_PTR => 0xc00c;

  sub new {
    my $class = shift;

    my $self = {
      sessions     => {},
      last_timeout => time,
      @_
    };

    bless $self, $class;
  }

  sub add_request {
    my ($self, $dns_request) = @_;
    Log->debug("Adding session for %s\n", $dns_request->domain);
    push @{ $self->{sessions}{lc $dns_request->domain} }, $dns_request;
  }

  sub _pack_name {
    join( '', map chr(length).$_, split /\./, $_[1] )."\0";
  }

  sub _pack_response {
    my ($self, $id, $flags, $req_type, $domain, $addr) = @_;

    my ($qd, $an, $ns, $ar) = (1, 0, 0, 0);

    my $answer;
    if ($addr) {
      $an = 1;
      $answer = pack('n3Nn', NAME_PTR, TYPE_A, CLASS_IN, 0, 4).inet_aton($addr);
    }

    # header
    my $response = pack 'n6', $id, $flags, $qd, $an, $ns, $ar;
    # question
    $response .= $self->_pack_name($domain).pack('n2', $req_type, CLASS_IN);
    # answer
    $response .= $answer if $an;

    return $response;
  }

  sub exists {
    my ($self, $domain) = @_;
    return exists $self->{sessions}{lc $domain};
  }

  sub flush {
    my $self = shift;
    $self->send_response($_ => 0)
      for keys %{ $self->{sessions} };
  }

  sub send_response {
    my ($self, $domain, $addr) = @_;

    if (not $self->exists($domain)) {
      Log->debug("Session not found for $domain\n");
      return;
    }

    my $requests = $self->{sessions}{lc $domain};

    my $flags = $addr ne '0' ? NOERROR : SERVFAIL;
    undef $addr if $addr eq '0';

    while (my $request = shift @$requests) {
      if (defined $addr) {
        Log->info("Resolved %s => %s, sent to %s:%s\n", $domain, $addr,
          $request->remote_addr, $request->remote_port);
      } else {
        Log->info("Failed to resolve %s, sent to %s:%s\n", $domain,
          $request->remote_addr, $request->remote_port);
      }

      my $response = $self->_pack_response(
        $request->id,
        $flags,
        $request->type,
        $request->domain,
        $addr
      );

      send $self->{handle}, $response, 0, $request->remote_sa;
    }

    delete $self->{sessions}{lc $domain};
  }

  sub timeout {
    my $self = shift;

    my $limit = time - $self->{timeout};
    return if $limit < $self->{last_timeout};

    for (keys %{ $self->{sessions} }) {
      delete $self->{sessions}{$_}
        if $self->{sessions}{$_}[0]->time < $limit;
    }

    $self->{last_timeout} = time;
  }

  sub handle {
    my $self = shift;
    $self->{handle} = shift if @_;
    return $self->{handle};
  }

  1;
}

{
  package DNS::Request;

  use strict;
  use warnings;

  use Socket;

  use constant INVALID        => 0;
  use constant FORMERR        => 0x8101;
  use constant SERVFAIL       => 0x8102;

  use constant TYPE_A         => 1;
  use constant TYPE_AAAA      => 0x1c;
  use constant CLASS_IN       => 1;

  use constant MAX_LABEL_LEN  => 63;
  use constant MAX_DOMAIN_LEN => 255;

  sub receive {
    my ($class, $handle) = @_;

    my $remote_sa = recv $handle, my $query, 512, 0;
    return unless defined $remote_sa;

    my $self = {
      query     => $query,
      remote_sa => $remote_sa,
      time      => time
    };

    bless $self, $class;
  }

  sub _unpack_name {
    my ($self, $pos) = @_;

    return if length $self->{query} < $pos + 2;

    my @labels;
    while (my $len = ord substr $self->{query}, $pos, 1) {
      return if ($len & 0xc0) == 0xc0 or length $self->{query} < $pos+$len+2;
      push @labels, substr $self->{query}, ++$pos, $len;
      $pos += $len;
    }

    return $pos + 1, @labels;
  }

  sub remote_addr {
    my $self = shift;
    my (undef, $remote_addr) = sockaddr_in $self->{remote_sa};
    return inet_ntoa $remote_addr;
  }

  sub remote_port {
    my $self = shift;
    (sockaddr_in $self->{remote_sa})[0];
  }

  sub parse {
    my $self = shift;

    Log->info("Received datagram from %s:%s\n",
      $self->remote_addr, $self->remote_port);

    if (length $self->{query} < 19) {
      Log->info("Dropping invalid packet from %s:%s\n",
        $self->remote_addr, $self->remote_port);
      $self->{error} = INVALID;
      return;
    }

    my ($id, $flags, $qd, $an, $ns, $ar) = unpack 'n6', $self->{query};
    my $pos = 12;

    Log->info("id=0x%04x flags=0x%04x qd=0x%04x an=0x%04x ".
               "ns=0x%04x ar=0x%04x\n", $id, $flags, $qd, $an, $ns, $ar);

    unless ($qd == 1
            and $an == 0 and $ns == 0 and $ar == 0) {
      Log->info("Server failure (unsupported) to %s:%s\n",
        $self->remote_addr, $self->remote_port);
      $self->{error} = SERVFAIL;
      return;
    }

    my @labels;
    ($pos, @labels) = $self->_unpack_name($pos);
    unless ($pos and length $self->{query} >= $pos + 4) {
      Log->info("Format error (invalid name or length) to %s:%s\n",
        $self->remote_addr, $self->remote_port);
      $self->{error} = FORMERR;
      return;
    }

    my ($type, $class) = unpack 'n2', substr $self->{query}, $pos, 4;
    $pos += 4;
#    unless ($type == TYPE_A) {
# || $type == TYPE_AAAA and $class == CLASS_IN) {
#      Log->info("Server failure (unsupported type/class) to %s:%s\n",
#        $self->remote_addr, $self->remote_port);
#      $self->{error} = SERVFAIL;
#      return;
#    }

    my $domain_len = 0;
    for my $label (@labels) {
      my $label_len = length $label;
      $domain_len += 1 + $label_len;
      unless ($label_len <= MAX_LABEL_LEN and
              $domain_len <= MAX_DOMAIN_LEN and
              # labels can only start with a letter, but we need
              # to allow numbers for .onion names
              $label =~ /(\A[[:alnum:]](?:[[:alnum:]\-]*[[:alnum:]])?\z)/) {
        Log->info("Format error (invalid label/domain) to %s:%s\n",
          $self->remote_addr, $self->remote_port);
        $self->{error} = FORMERR;
        return;
      }
      $label = $1;
    }
    my $domain = join '.', @labels;

    %$self = (%$self, id => $id, type => $type, domain => $domain);

    return 1;
  }

  sub send_error {
    my ($self, $handle) = @_;

    return if $self->{error} == INVALID;

    my $response = substr($self->{query}, 0, 2).pack('n', $self->{error}).
                   substr($self->{query}, 4);
    send $handle, $response, 0, $self->{remote_sa};
  }

  sub remote_sa { $_[0]->{remote_sa} }
  sub id        { $_[0]->{id}        }
  sub domain    { $_[0]->{domain}    }
  sub type      { $_[0]->{type}      }
  sub time      { $_[0]->{time}      }

  1;
}

{
  package Connection;

  use strict;
  use warnings;

  use Socket;
  use Fcntl;

  my $Tcp_proto = getprotobyname 'tcp';

  sub connect {
    my ($self, $timeout) = @_;

    eval {
      local $SIG{ALRM} = sub { die "Connection timed out\n" };
      alarm $timeout;
      socket $self->{handle}, AF_INET, SOCK_STREAM, $Tcp_proto
        or die "socket() failed: $!\n";
      select( (select($self->{handle}), $| = 1)[0] );
      connect $self->{handle}, $self->{sockaddr}
        or die "connect() failed: $!\n";
    };
    alarm 0;
    close $self->{handle} if $@;

    return not $@;
  }

  sub _set_nonblocking {
    my $self = shift;

    my $flags = fcntl $self->{handle}, F_GETFL, 0
      or die "fcntl() failed: $!\n";
    fcntl $self->{handle}, F_SETFL, $flags | O_NONBLOCK
      or die "fcntl() failed: $!\n";
  }

  1;
}

{
  package Tor::Control;
  use base 'Connection';

  use strict;
  use warnings;

  use Socket qw/:DEFAULT :crlf/;
  use Errno 'EWOULDBLOCK';

  use constant BUF_SIZE       => 8192;
  use constant TIMEOUT        => 300;

  sub new {
    my $class = shift;

    my $self = {
      read_buf     => "\0" x BUF_SIZE,
      write_buf    => "\0" x BUF_SIZE,
      read_pos     => 0,
      write_pos    => 0,
      disconnected => 1,
      @_
    };

    bless $self, $class;
  }

  sub _read_auth_cookie {
    my $self = shift;

    my $cookie_file = "$self->{data_directory}/control_auth_cookie";
    if (open my $cookie_handle, '<', $cookie_file) {
      local $/;
      my $cookie = <$cookie_handle>;
      $self->{secret} = unpack 'H*', $cookie;
    } else {
      Log->info("Can't open $cookie_file: $!\n");
    }
  }

  sub _authenticate {
    my $self = shift;

    local $/ = CRLF;
    $self->_read_auth_cookie if $self->{data_directory};
    syswrite $self->{handle}, 'AUTHENTICATE '.$self->{secret}.CRLF
      or die "syswrite() failed: $!\n";
    defined( my $response = readline $self->{handle} )
      or die "readline() failed: $!\n";
    chomp $response;
    $response eq '250 OK'
      or die "Authentication failed\n";
  }

  sub connect {
    my $self = shift;

    my $timeout = 5;
    for (;;) {
      eval {
        $self->SUPER::connect($timeout) or die $@;
        local $SIG{ALRM} = sub { die "Authentication timed out\n" };
        alarm $timeout;
        $self->_authenticate;
        $self->_set_nonblocking if $^O ne 'MSWin32';
      };
      alarm 0;
      if ($@) {
        Log->info("$@Connection to Tor failed. Retrying...\n");
        close $self->{handle};
        sleep $timeout;
        last if $self->{terminate}->();
      } else {
        Log->info("Connected to Tor\n");
        $self->{disconnected} = 0;
        last;
      }
    }

    $self->{read_pos} = $self->{write_pos} = 0;
  }

  sub add_mapaddress_to_buf {
    my ($self, $domain) = @_;

    my $command = 'MAPADDRESS 0.0.0.0='.$domain.CRLF;
    my $len = length $command;
    if ($self->{write_pos} + $len < BUF_SIZE) {
      Log->debug("Adding mapaddress to buffer for $domain\n");
      substr $self->{write_buf}, $self->{write_pos}, $len, $command;
      $self->{write_pos} += $len;
    } else {
      Log->info("Write buffer full. Dropping packet.\n");
    }
  }

  sub _readline {
    my $self = shift;

    my $index = index substr($self->{read_buf}, 0, $self->{read_pos}), CRLF;
    return if $index == -1;

    my $len = $index + length CRLF;
    my $line = substr $self->{read_buf}, 0, $len;
    if ($len == $self->{read_pos}) {
      $self->{read_pos} = 0;
    } else {
      substr $self->{read_buf}, 0, $self->{read_pos} - $len,
        substr $self->{read_buf}, $len, $self->{read_pos} - $len;
      $self->{read_pos} -= $len;
    }

    return $line;
  }

  sub _read_mapaddress_response {
    my $self = shift;

    local $/ = CRLF;
    while (defined( my $line = $self->_readline )) {
      chomp $line;
      my ($code, $ret) = split / /, $line;
      next unless defined $code and $code eq '250';

      my ($addr, $domain) = split /=/, $ret;
      $self->{dns_session}->send_response($domain => $addr);
    }
  }

  sub read {
    my $self = shift;

    Log->debug("Handling read from Tor control port\n");

    my $bytes = sysread $self->{handle}, $self->{read_buf},
                        BUF_SIZE - $self->{read_pos}, $self->{read_pos};
    if ($bytes) {
      $self->{read_pos} += $bytes;
      $self->_read_mapaddress_response;
    } elsif (defined $bytes && $bytes == 0 or $! != EWOULDBLOCK) {
      Log->info("Tor closed control connection\n");
      $self->{dns_session}->flush;
      $self->{disconnected} = 1;
    }
  }

  sub write {
    my $self = shift;

    Log->debug("Handling write to Tor control port\n");

    my $bytes = syswrite $self->{handle},$self->{write_buf},$self->{write_pos};
    if (defined $bytes) {
      if ($bytes == $self->{write_pos}) {
        $self->{write_pos} = 0;
      } else {
        substr $self->{write_buf}, 0, $self->{write_pos} - $bytes,
          substr $self->{write_buf}, $bytes, $self->{write_pos} - $bytes;
        $self->{write_pos} -= $bytes;
      }
    } elsif ($! != EWOULDBLOCK) {
      Log->info("syswrite() error: $!\n");
      $self->{dns_session}->flush;
      $self->{disconnected} = 1;
    }
  }

  sub can_write    { $_[0]->{write_pos} > 0 }

  sub handle       { $_[0]->{handle}       }
  sub disconnected { $_[0]->{disconnected} }

  1;
}

{
  package Socks::Resolve;
  use base 'Connection';

  use strict;
  use warnings;

  use Socket;
  use Errno 'EWOULDBLOCK';

  sub _add_request_to_buf {
    my $self = shift;
    Log->debug("Adding SOCKS resolve request to buffer\n");
    $self->{write_buf} = "\4\xf0\0\0\0\0\0\1\0$self->{domain}\0";
  }

  sub connect {
    my $class = shift;

    my $self = {
      handle   => undef,
      read_buf => '',
      time     => time,
      @_
    };

    bless $self, $class;

    my $timeout = 1;
    eval {
      # blocking connect shouldn't be a problem when tor is on loopback
      $self->SUPER::connect($timeout) or die $@;
      $self->_set_nonblocking if $^O ne 'MSWin32';
    };
    if ($@) {
      Log->info("$@SOCKS connection failed, dropping request\n");
      close $self->{handle};
      return;
    }

    $self->_add_request_to_buf;
    return $self;
  }

  sub _fail {
    my $self = shift;

    Log->info("SOCKS resolve failed for $self->{domain}\n");
    $self->{dns_session}->send_response($self->{domain} => 0);
    $self->{disconnected} = 1;
  }

  sub read {
    my $self = shift;

    Log->debug("Handling read from Tor SOCKS port\n");

    my $bytes = sysread $self->{handle}, my $buf, 8 - length $self->{read_buf};
    if (not defined $bytes) {
      $self->_fail if $! != EWOULDBLOCK;
      return;
    }

    $self->{read_buf} .= $buf;

    if (length $self->{read_buf} < 8) {
      $self->_fail if $bytes == 0;
      return;
    }

    my ($ver, $res, $port) = unpack 'CCn', $self->{read_buf};
    my $addr = substr $self->{read_buf}, 4, 4;
    if ($res != 90) {
      $self->_fail;
      return;
    }

    $self->{dns_session}->send_response($self->{domain} => inet_ntoa($addr));
    $self->{disconnected} = 1;
  }

  sub write {
    my $self = shift;

    Log->debug("Handling write to Tor SOCKS port\n");

    if (defined( my $bytes = syswrite $self->{handle}, $self->{write_buf} )) {
      substr $self->{write_buf}, 0, $bytes, '';
      delete $self->{write_buf} if length $self->{write_buf} == 0;
    } else {
      $self->_fail if $! != EWOULDBLOCK;
    }
  }

  sub can_read     { not exists $_[0]->{write_buf} }

  sub time         { $_[0]->{time}         }
  sub handle       { $_[0]->{handle}       }
  sub disconnected { $_[0]->{disconnected} }

  1;
}

{
  package DNS::Server;

  use strict;
  use warnings;

  use Socket;
  use POSIX;
  use Getopt::Std;
  use IO::Poll qw/POLLIN POLLOUT POLLERR POLLHUP/;

  use constant TIMEOUT => 300;

  my $Tcp_proto = getprotobyname 'tcp';

  sub new {
    my $class = shift;
    my $self = { @_ };
    bless $self, $class;
  }

  sub _fail {
    my $self = shift;
    print <<USAGE, @_;
Usage: $0 -b bind_addr:bind_port -t tor_ctrl_addr:tor_ctrl_port
\t[-f] [-s socks_addr:socks_port] [-u user:group] [-p pid_file]
\t[-c chroot_dir] [-k data_dir] [-w passwd] [-v log_level] [-l log_file]
USAGE
    exit 1;
  }

  sub _set_ugid {
    my ($self, $opt_u) = @_;

    my ($user, $group) = split /:/, $opt_u;
    $self->_fail("Invalid user:group\n")
      unless $user and $group;

    defined( $self->{uid} = getpwnam $user )
      or $self->_fail("getpwnam($user) failed\n");
    defined( $self->{gid} = getgrnam $group )
      or $self->_fail("getgrnam($group) failed\n");
  }

  sub _sockaddr {
    my ($self, $port, $addr) = @_;
    return if $addr !~ /\A(?:\d+\.){3}\d+\z/;
    eval { sockaddr_in $port, pack 'C4', split /\./, $addr };
  }

  sub _open_tor_control {
    my $self = shift;
    $self->{tor_control} = Tor::Control->new(
      sockaddr       => $self->{tor_control_sa},
      dns_session    => $self->{dns_session},
      data_directory => $self->{data_directory} || undef,
      secret         => $self->{secret},
      terminate      => $self->{terminate}
    );
    my ($level, $handle) = (Log->level, Log->handle);
    Log->level(Log::DEBUG); Log->handle(*STDERR);
    $self->{tor_control}->connect;
    Log->level($level); Log->handle($handle);
  }

  sub _test_socks {
    my $self = shift;
    socket my $socks_test, AF_INET, SOCK_STREAM, $Tcp_proto
      or $self->_fail("socket() failed: $!\n");
    connect $socks_test, $self->{socks_sa}
      or $self->_fail("Connection failed to Tor SOCKS port\n");
    close $socks_test;
  }

  sub _bind {
    my $self = shift;

    socket $self->{handle}, AF_INET, SOCK_DGRAM, scalar getprotobyname 'udp'
      or $self->_fail("socket() failed: $!\n");
    setsockopt $self->{handle}, SOL_SOCKET, SO_REUSEADDR, 1
      or $self->_fail("setsockopt(SO_REUSEADDR) failed: $!\n");
    bind $self->{handle}, $self->{bind_sa}
      or $self->_fail("bind() failed: $!\n");

    $self->{dns_session} = DNS::Session->new(
      handle  => $self->{handle},
      timeout => TIMEOUT
    );
  }

  sub _daemonize {
    my $self = shift;
    defined( fork and exit )
      or $self->_fail("Can't fork: $!\n");
    POSIX::setsid
      or $self->_fail("setsid(): Can't create a new session: $!\n");
    chdir '/';
    umask 0;
    open $_, '+<', '/dev/null'
      or $self->_fail("Can't reopen $_ to /dev/null: $!")
        for *STDIN, *STDOUT, *STDERR;
  }

  sub _write_pid_file {
    my $self = shift;
    my $pid_handle = $self->{pid_handle};
    print $pid_handle $$;
    close $self->{pid_handle};
  }

  sub _chroot {
    my $self = shift;
    chroot $self->{chroot} and chdir '/'
      or $self->_fail("Can't chroot to $self->{chroot}: $!\n");
  }

  sub _drop_privileges {
    my $self = shift;
    $) = "$self->{gid} $self->{gid}";
    $( = $self->{gid};
    $> = $self->{uid};
    $< = $self->{uid};
    $self->_fail("Can't drop privileges to $self->{uid}:$self->{gid}: $!\n")
      if $) ne "$self->{gid} $self->{gid}" or $( != $self->{gid} or
         $> != $self->{uid} or $< != $self->{uid};
  }

  sub parse_options {
    my $self = shift;

    getopts 'b:t:s:u:p:c:v:k:w:l:f', \my %opt;

    defined $opt{$_} or $self->_fail
      for qw/b t/;

    $self->_fail("Can't set both cookie and password\n")
      if $opt{k} and $opt{w};
    $self->_fail("Can't set log file without log level\n")
      if $opt{l} and not $opt{v};
    $self->_fail("Must be run as root to chroot\n")
      if $opt{c} and $> != 0;
    $self->_fail("Must be run as root to drop privileges\n")
      if $opt{u} and $> != 0;

    my ($bind_addr, $bind_port) = split /:/, $opt{b};
    my ($tor_ctrl_addr, $tor_ctrl_port) = split /:/, $opt{t};
    defined $_ or $self->_fail
      for $bind_addr, $bind_port, $tor_ctrl_addr, $tor_ctrl_port;

    if ($bind_addr eq 'any') {
      $bind_addr = inet_ntoa INADDR_ANY;
    } elsif ($bind_addr eq 'lo') {
      $bind_addr = inet_ntoa INADDR_LOOPBACK;
    }

    $self->{bind_sa} = $self->_sockaddr($bind_port, $bind_addr)
      or $self->_fail("Invalid bind address or port\n");

    $self->{tor_control_sa} = $self->_sockaddr($tor_ctrl_port, $tor_ctrl_addr)
      or $self->_fail("Invalid Tor control address or port\n");

    if ($opt{s}) {
      my ($socks_addr, $socks_port) = split /:/, $opt{s};
      defined $_ or $self->_fail
        for $socks_addr, $socks_port;
      $self->{socks_sa} = $self->_sockaddr($socks_port, $socks_addr);
    }

    if ($opt{v}) {
      $opt{v} =~ /\A([1-2])\z/
        or $self->_fail("Log levels 1-2 are valid\n");
      my $log_level = (Log::INFO, Log::DEBUG)[$1 - 1];
      if ($opt{l}) {
        Log->init(level => $log_level, file => $opt{l})
          or $self->_fail($Log::Err);
      } else {
        Log->init(level => $log_level, handle => *STDERR);
      }
    }

    open $self->{pid_handle}, '>', $opt{p}
      or $self->_fail("Can't open pid_file $opt{p} for writing: $!\n")
        if $opt{p};

    $self->_set_ugid($opt{u}) if $opt{u};

    $self->{secret} = '';
    if ($opt{k}) {
      $self->{data_directory} = $opt{k};
    } elsif ($opt{w}) {
      $self->{secret} = unpack 'H*', $opt{w};
    }

    $self->{chroot} = $opt{c} if $opt{c};
    $self->{foreground} = 1 if $opt{f};
  }

  sub _dns_request_handler {
    my $self = shift;

    my $dns_request = receive DNS::Request $self->{handle} or return;

    if (not $dns_request->parse) {
      $dns_request->send_error($self->{handle});
      return;
    }

    if (not $self->{dns_session}->exists($dns_request->domain)) {
      if ($self->{socks_sa} and $dns_request->domain !~ /\.(?:exit|onion)\z/) {
        my $socks_resolve = Socks::Resolve->connect(
          sockaddr    => $self->{socks_sa},
          dns_session => $self->{dns_session},
          domain      => $dns_request->domain
        ) or return;
        $self->{poll}->mask($socks_resolve->handle => POLLOUT);
        $self->{socks_resolve}{$socks_resolve->handle} = $socks_resolve;
      } else {
        $self->{tor_control}->add_mapaddress_to_buf($dns_request->domain);
        $self->{poll}->mask($self->{tor_control}->handle => POLLIN | POLLOUT);
      }
    }

    $self->{dns_session}->add_request($dns_request);
  }

  sub _tor_control_handler {
    my ($self, $handle, $event) = @_;

    if ($event == POLLIN) {
      $self->{tor_control}->read;
    } else {
      $self->{tor_control}->write;
    }

    if ($self->{tor_control}->disconnected) {
      $self->{poll}->remove($handle);
      $self->{tor_control}->connect;
    }

    $self->{poll}->mask($handle => POLLIN)
      unless $self->{tor_control}->can_write;
  }

  sub _socks_resolve_handler {
    my ($self, $handle, $event) = @_;

    if ($event == POLLIN) {
      $self->{socks_resolve}{$handle}->read;
    } else {
      $self->{socks_resolve}{$handle}->write;
    }

    if ($self->{socks_resolve}{$handle}->disconnected) {
      $self->{poll}->remove($handle);
      delete $self->{socks_resolve}{$handle};
    } elsif ($self->{socks_resolve}{$handle}->can_read) {
      $self->{poll}->mask($handle => POLLIN);
    }
  }

  sub _timeout {
    my $self = shift;

    my $limit = time - TIMEOUT;
    return unless $self->{last_timeout} < $limit;

    $self->{dns_session}->timeout;

    for (keys %{ $self->{socks_resolve} }) {
      if ($self->{socks_resolve}{$_}{time} < $limit) {
        $self->{poll}->remove($self->{socks_resolve}{$_}->handle);
        delete $self->{socks_resolve}{$_};
      }
    }

    $self->{last_timeout} = time;
  }

  sub _event_loop {
    my $self = shift;

    $self->{poll} = IO::Poll->new;

    $self->{poll}->mask($_ => POLLIN)
      for $self->{handle}, $self->{tor_control}->handle;

    $self->{last_timeout} = time;

    for (;;) {
      $self->{poll}->poll;
      last if $self->{terminate}->();

      for my $h ($self->{poll}->handles(POLLIN | POLLERR | POLLHUP)) {
        if ($h eq $self->{handle}) {
          $self->_dns_request_handler;
        } elsif ($h eq $self->{tor_control}->handle) {
          $self->_tor_control_handler($h, POLLIN);
        } else {
          $self->_socks_resolve_handler($h, POLLIN);
        }
      }

      for my $h ($self->{poll}->handles(POLLOUT)) {
        if ($h eq $self->{tor_control}->handle) {
          $self->_tor_control_handler($h, POLLOUT);
        } else {
          $self->_socks_resolve_handler($h, POLLOUT);
        }
      }

      $self->_timeout;
    }

    delete $self->{poll};
    delete $self->{socks_resolve};
    $self->{dns_session}->flush;
  }

  sub _cleanup {
    my $self = shift;

    delete $self->{dns_session};
    delete $self->{tor_control};
    close $self->{handle}        if $self->{handle};
    Log->close                   if Log->handle;
  }

  sub DESTROY {
    my $self = shift;
    $self->_cleanup;
  }

  sub serve {
    my $self = shift;

    local %SIG;
    $SIG{PIPE} = 'IGNORE';

    my $terminate = 0;
    $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $terminate = 1 };
    $self->{terminate} = sub { $terminate };

    $self->_bind;
    $self->_open_tor_control;

    if ($self->{terminate}->()) {
      $self->_cleanup;
      return;
    }

    $self->_test_socks        if $self->{socks_sa};
    $self->_daemonize         unless $self->{foreground} or $^O eq 'MSWin32';
    $self->_write_pid_file    if $self->{pid_handle};
    $self->_chroot            if $self->{chroot};
    $self->_drop_privileges   if $self->{uid};

    $self->_event_loop;

    $self->_cleanup;
  }

  1;
}

my $server = DNS::Server->new;
$server->parse_options;
$server->serve;

=head1 NAME

B<dns-proxy-tor> - A DNS server for plugging DNS leaks when using Tor

=head1 SYNOPSIS

B<dns-proxy-tor> B<-b> I<bind_addr>:I<bind_port>
              B<-t> I<tor_ctrl_addr>:I<tor_ctrl_port>
              [B<-s> I<socks_addr>:I<socks_port>]
              [B<-u> I<user>:I<group>] [B<-c> I<chroot_dir>]
              [B<-p> I<pid_file>] [B<-k> I<data_dir>] [B<-w> I<passwd>]
              [B<-f>] [B<-v> I<log_level>] [B<-l> I<log_file>]

=head1 DESCRIPTION

B<dns-proxy-tor> is a DNS server that instructs B<tor> to map a domain name to
a fake IP address, then responds with that fake address. Subsequently, B<tor>
will send connections intended for the fake address to the mapped domain name
instead. Actual domain names, C<.onion> names, and C<.node.exit> names work
using this method.

I<ControlPort> must be specified in your I<torrc> before B<tor> will listen on
the port needed for communication with B<dns-proxy-tor>.

If you want B<dns-proxy-tor> to answer queries over a network rather than just
over the loopback interface, you'll need to set I<VirtualAddrNetwork> in your
I<torrc> to C<10.192.0.0/10> or C<172.16.0.0/12>. This is necessary because by
default, B<tor> supplies fake addresses in the network 127.192.0.0/10, which
properly configured machines will route to the loopback interface.

Use the B<-s> option to resolve domain names with B<tor>'s SOCKS resolve
extension instead of the C<MAPADDRESS> controller command. You must use this
option if you want applications to resolve names through B<tor>, but make their
actual connections directly. Even when the B<-s> option is specified,
C<.node.exit> and C<.onion> names will still be resolved with C<MAPADDRESS>.

=head1 OPTIONS

B<-b> I<address>:I<port>
        Bind the proxy to I<address> and I<port>. I<address> can be
        either an IP address, C<lo> for the loopback
        interface, or C<any> for all interfaces. If you
        are forwarding connections to B<dns-proxy-tor>
        with pf or iptables rules, this should be
        C<lo:5353> or C<any:5353>. Otherwise, it should
        be C<lo:53> or C<any:53>. Binding to port 53
        requires root privileges.

B<-t> I<address>:I<port>
        Send C<MAPADDRESS> B<tor> controller commands to B<tor>
        on I<address> and I<port>. I<address> must be an IP
        address. When B<tor> is listening on the loopback
        interface, this should be C<127.0.0.1:9051>.

B<-s> I<address>:I<port>
        Send SOCKS resolve requests to B<tor> on I<address> and
        I<port>. I<address> must be an IP address. When B<tor>
        is listening on the loopback interface, this
        should be C<127.0.0.1:9050>.

B<-u> I<user>:I<group>
        Drop privileges to those of I<user> and I<group>. Only
        available when run as a privileged user.

B<-p> I<filename>
        Write PID to I<filename>.

B<-c> I<directory>
        Change root directory to I<directory>. Specify B<-u>
        also to make this irreversible. Only available
        when run as a privileged user.

B<-f>      Run in the foreground.

B<-v> I<level>
        Output log messages at I<level>. Available levels
        are 1 and 2. Level 2 is more verbose than level 1.
        Messages will be sent to stderr unless B<-l> is set.

B<-l> I<file>
        Write log messages to I<file>.

B<-k> I<directory>
        Authenticate to the B<tor> control port with the
        C<control_auth_cookie> file located in B<tor>'s
        data directory, I<directory>. Add
        I<CookieAuthentication> to your I<torrc> to
        enable this form of authentication. Cookie
        authentication doesn't work in B<tor> 0.1.1.20
        and earlier. Typically, B<dns-proxy-tor> should
        be run as the same user B<tor> runs as to
        access I<directory>. If running in a chroot,
        I<directory> should be accessible both inside
        and outside the chroot from the same path.

B<-w> I<password>
        Authenticate to the B<tor> control port with
        I<password>. To enable this form of
        authentication, generate a hashed password with
        C<< tor --hash-password <password> >>, then place
        the hashed password in your I<torrc> as the
        I<HashedControlPassword>.

=head1 SEE ALSO

B<trans-proxy-tor>, L<tor(8)>, L<pf(4)>, L<pfctl(8)>, L<pf.conf(5)>, L<iptables(8)>

=head1 COPYRIGHT

B<dns-proxy-tor> has been dedicated to the public domain. It has no
copyright.

=cut