Summerschool Aachen 2004/Project Day I

HTTP Tunnelling

I was planning to implement in my project first a simple program and then extend it to a more "advanced" program: Assume we have a host H1 behind a firewall F who wants to communicate with a host H2 who is outside the firewall. Let us further assume that the firewall F only lets HTTP packets through, i.e. packets with destination port 80, and assume that host H1 wants to build up an SSH connection with host H2. I want first to write a (static) C program run on a host X between host H1 and H2, such that H1 can contact build up an SSH connection with X at port 80 (meaning that the traffic will be let through by F) and X forwards the traffic to H2 at port 22. F should also forward the traffic from H2 to H1. Later I want to extend this program to a more dynamic program in a way that H1 can tell X with whom he wants to build up an SSH connection and X does this. If there is still some time left (which I hope there will be :)) I would like to extend that program to a more generic program which cannot only forward SSH traffic but also SMTP and other kinds of traffic. I know that there are probably already many tunnelling programs doing such kinds of things. However, as I don't have that much experience of network programming (except a small webserver I have once set up in Java) I think that such a project will help me to improve my skills in network programming.

--Samad Nasserian

Fingerprinting Tool in perl

This is the current version of the fingerprinting tool, I'm working on.

#!/usr/bin/perl -w

use strict;

# ---------------------------------------------------------------------------------
package Net::DNS::PacketExt;

   use strict;
   use vars qw(@ISA);

   @ISA = qw(Net::DNS::Packet);

   sub new
   {
      my $proto = shift;
      my $class = ref $proto || $proto;
      my $data  = shift;

      my $self = Net::DNS::Packet->new($data);
      $self->{"header"} = Net::DNS::HeaderExt->new($data);

      bless $self, $class;
      return $self;
   }

1;

# ---------------------------------------------------------------------------------

package Net::DNS::HeaderExt;

   use strict;
   use vars qw(@ISA);

   @ISA = qw(Net::DNS::Header);

   sub new
   {
      my $proto = shift;
      my $class = ref $proto || $proto;
      my $data  = shift;

      my $self = Net::DNS::Header->new($data);

      my @a = unpack("n C2 n4", $$data);

      $self->{"z0"} = ($a[2] >> 6) & 0x1;
      $self->{"z1"} = ($a[2] >> 5) & 0x1;
      $self->{"z2"} = ($a[2] >> 4) & 0x1;

      bless $self, $class;
      return $self;
   }

1;

# ---------------------------------------------------------------------------------

package MapTool;

   use strict;
   use Carp;

   sub new
   {
      my $proto = shift;
      my $class = ref $proto || $proto;
      my $targethost = $_[0] or croak "need target host";

      my %self;
      $self{targethost} = $targethost;

      $self{smtp} = MapTool::Smtp->new();
      $self{ftp}  = MapTool::Ftp->new();
      $self{dns}  = MapTool::Dns->new();

      bless \%self, $class;
      return \%self;
   }

   sub probe
   {
      my $self = shift;

      $self->{dns}->probe($self->{targethost});
   }

   sub results
   {
      my $self = shift;

      $self->{dns}->results();
   }

1;

# ---------------------------------------------------------------------------------

package MapTool::Smtp;

   use strict;
   use vars qw/@ISA/;
   use Carp;
   use Net::DNS::Resolver;

   @ISA = ("MapTool");

   my $mydomain   = 'ccc.de';
   my $validsrc   = 'cpunkt@ccc.de';

   sub new
   {
      my $proto = shift;
      my $class = ref($proto) || $proto;

      my $fpres   = "smtp_fingerprints";
      my $fpcmd   = "smtp_tests";


      my $self = {};

      bless $self, $class;
      $self->mkdb($fpcmd, $fpres);

      return $self;
   }

   sub mkdb
   {
      my $self = shift;

      $self->{commands} = [];
      $self->{fingerprints}  = {};

      open TESTS,   "$_[0]" or croak "can't open $_[0]";
      open RESULTS, "$_[1]" or croak "can't open $_[1]";

      while (my $tline = <TESTS>) {
         next if ($tline =~ /^#/);
         chomp $tline;

         my $invalidsrc = $self->generate_source_address();

         $tline =~ s/\$MY_DOMAIN/${mydomain}/g;
         $tline =~ s/\$VALID_SOURCE/${validsrc}/g;
         $tline =~ s/\$INVALID_SOURCE/${invalidsrc}/g;

         my @cmd_sequence = split /->/, $tline;

         push @{$self->{commands}}, \@cmd_sequence;
      }

      close TESTS;

      while (my $rline = <RESULTS>) {
         next if ($rline =~ /^#/);
         chomp $rline;

         my @res_sequence = split /:/, $rline;
         my $software_version = shift @res_sequence;

         $self->{fingerprints}->{$software_version} = \@res_sequence;
      }

      close RESULTS;
   }

   sub generate_source_address
   {
      my ($i, $ok, $query);
      my ($fake_domain, $fake_user) = ('', '');
      my $res = Net::DNS::Resolver->new;
      my @VALID_CHARS = ( 'A' .. 'Z', 'a' .. 'z', '0' .. '9', '_');

      while (not $ok) {
         for $i (1 .. 25) {
            $fake_domain .= $VALID_CHARS[int rand(@VALID_CHARS)];
         }

         $fake_domain .= '.com';
         $ok = 1;

         $query = $res->query($fake_domain, 'SOA');

         $ok = 1 if (not $query);
      }

      for $i (1 .. 10) {
         $fake_user .= $VALID_CHARS[int rand(@VALID_CHARS)];
      }

      return "$fake_user\@$fake_domain";
   }

1;

# ---------------------------------------------------------------------------------

package MapTool::Ftp;

   use strict;
   use vars qw/@ISA/;
   use Carp;

   @ISA = ("MapTool");

   sub new
   {
      my $proto = shift;
      my $class = ref($proto) || $proto;

      my $fpres   = "ftp_fingerprints";
      my $fpcmd   = "ftp_tests";

      my $self = {};

      bless $self, $class;
      $self->mkdb($fpcmd, $fpres);

      return $self;
   }

   sub mkdb
   {
      my $self = shift;

      $self->{commands} = [];
      $self->{fingerprints}  = {};

      open TESTS,   "$_[0]" or croak "can't open $_[0]";
      open RESULTS, "$_[1]" or croak "can't open $_[1]";

      my $isnulled = 0;

      while (my $tline = <TESTS>) {
         next if ($tline =~ /^#/);
         chomp $tline;

         if ($tline =~ /^#if 0/) {
            $isnulled = 1;
         } elsif ($isnulled && $tline =~ /^#endif/) {
            $isnulled = 0;
         }

         next if ($isnulled || $tline !~ /^\s*"([^"]+)"/);

         push @{$self->{commands}}, $1;
      }

      close TESTS;

      my $inblock = 0;
      my $softwareversion;

      while (my $rline = <RESULTS>) {
         chomp $rline;

         if ($inblock && $rline =~ /^\s*\}/) {
            $inblock = 0;
            $softwareversion = '';
            next;
         } elsif ($inblock) {
            my @checksums = split /,/, $rline;
            push @{$self->{fingerprints}->{$softwareversion}}, \@checksums;
            next;
         }

         if ($rline =~ /^\s*0UL,\s*"([^"]+)"/) {
            $softwareversion = $1;
            $inblock = 1
         }
      }

      close RESULTS;
   }

1;

# ---------------------------------------------------------------------------------

package MapTool::Dns;

   use strict;
   use vars qw/@ISA/;
   use Carp;
   use LWP::UserAgent;
   use Sys::Hostname;
   use Socket;

   @ISA = ("MapTool");

   sub new
   {
      my $proto = shift;
      my $class = ref($proto) || $proto;

      my $self = {};

      my $ua = LWP::UserAgent->new;
      $ua->timeout(23);

      my $djb_response = $ua->get('http://cr.yp.to/surveys/dns1.html');

      if ($djb_response->is_success) {
         bless $self, $class;
         $self->mkdb($djb_response->content);
         return $self;
      }

      croak $djb_response->status_line;
   }

   sub mkdb
   {
      my $self = shift;

      $self->{commands} = [];
      $self->{fingerprints}  = {};

      my $html_response = $_[0];
      my @html_lines = split /\n/, $html_response;

      my $tables = 0;
      my $table_open = 0;

      $self->{commands} = [
         "\0\0\10\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\3",
         "\0\0\0\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\77",
         "\0\0\0\0\0\2\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1\0\0\20\0\1",
         "\0\0\40\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\50\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\0\0\0\0\0\0\0\0\0",
         "\0\0\0\0\0\1\0\0\0\0\0\0\6",
         "\0\0\0\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0",
         "\0\0\2\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\0\0\1\0\0\0\0\0\0\7Authors\4BIND\0\0\20\0\3",
         "\0\0\4\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\17\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\20\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\40\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\100\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\20\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\30\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\60\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\0\0\1\0\0\0\0\0\0\4test\17network-surveys\2cr\2yp\2to\0\0\20\0\1",
         "\0\0\0\0\0\1\0\0\0\0\0\0\25erre-con-erre-cigarro\7maradns\3org\0\0\20\0\1",
         "\0\0\0\0\0\1\0\0\0\0\0\0\7version\6server\0\0\20\0\3",
         "\0\0\0\0\0\1\0\0\0\0\0\0\7version\4bind\0\0\20\0\3"
      ];

      foreach my $hline (@html_lines) {
         if ($hline =~ /<table/) {
            $tables++;
            $table_open = 1;
            next;
         } elsif ($hline =~ /<\/table/) {
            $table_open = 0;
            next;
         }

         if ($tables > 3 && $tables < 10 && $table_open) {
            if ($hline =~ /<tr><td>Software/ || $hline !~ s/<tr><td>([^<]+)<\/td>//) {
               next;
            }

            my $softwareversion = $1;
            my @results;

            while ($hline =~ s/<td>([^<]+)<\/td>//) {
               push @results, $1;
            }

            push @{$self->{fingerprints}->{$softwareversion}}, \@results;
         }
      }
   }

   sub probe
   {
      my $self = shift;
      my $targethost = $_[0];

      my $iaddr = inet_aton("0.0.0.0");
      my $proto = getprotobyname('udp');
      my $port  = getservbyname('domain', 'udp');
      my $paddr = sockaddr_in(0, $iaddr);

      socket(SOCK, PF_INET, SOCK_DGRAM, $proto)  || croak "socket: $!";
      bind(SOCK, $paddr) || croak "bind: $!";

      $| = 1;

      my $hisiaddr = inet_aton($targethost) || croak "unknown host";
      my $hispaddr = sockaddr_in($port, $hisiaddr);

      my $count = 0;

      foreach my $request (@{$self->{commands}}) {
         $count++;

         defined(send(SOCK, $request, 0, $hispaddr)) || croak "send ".$targethost.": $!";

         my $rin = '';
         vec($rin, fileno(SOCK), 1) = 1;

         my $rout;

         if (!select($rout = $rin, undef, undef, 3.0)) {
            $count > 0 && do { $count = 0; $self->pushresult("timeout"); next; };
            redo;
         }

         my $response;

         ($hispaddr = recv(SOCK, $response, 1000, 0)) || croak "recv: $!";

         $self->pushresult($response);

         $count = 0;
      }
   }

   sub pushresult
   {
      my $self = shift;
      my $result = $_[0];

      push @{$self->{answers}}, $result;
   }

   sub results
   {
      my $self = shift;

      if (scalar @{$self->{answers}} != scalar @{$self->{commands}}) {
         croak "number of answers doesn't match number of commands";
      }

      $self->{results} = {};

      foreach my $swversion (keys %{$self->{fingerprints}}) {
         for (my $j = 0; $j < scalar @{$self->{fingerprints}->{$swversion}}; $j++) {
            my $matchcount;

            for (my $i = 0; $i < scalar @{$self->{answers}}; $i++) {
               $matchcount += $self->compare($self->{answers}->[$i],
                                             $self->{fingerprints}->{$swversion}->[$j]->[$i]);
            }

            push @{$self->{results}->{$matchcount}}, $swversion;
         }
      }

      for (my $score = scalar @{$self->{answers}}; $score >= 0; $score--) {
         next unless (defined $self->{results}->{$score});

         print "matched with score ".int ($score/(scalar @{$self->{answers}})*100).":\n";
         map { print "\t$_\n"; } @{$self->{results}->{$score}};
      }
   }

   sub compare
   {
      my $self = shift;
      my ($response, $fingerprint) = @_;

      $fingerprint =~ s/\s+//g;

      if ($fingerprint =~ /t/) {
         return($response eq 'timeout');
      } elsif ($response eq 'timeout') {
         return 0;
      }

      my @alternatives = split /,/, $fingerprint;
      my $packet = Net::DNS::PacketExt->new(\$response);

      $packet || croak("DNS::Packet refuses the response...");

      my $header  = $packet->header;
      my @queries = $packet->question;
      my @answers = $packet->answer;

      my $match = 0;

      foreach my $alternative (@alternatives) {
         if ($alternative =~ s/0//) {
            $match = ($header->rcode eq 'NOERROR');
            next unless ($match);
         }
         if ($alternative =~ s/1//) {
            $match = ($header->rcode eq 'FORMERR');
            next unless ($match);
         }
         if ($alternative =~ s/2//) {
            $match = ($header->rcode eq 'SERVFAIL');
            next unless ($match);
         }
         if ($alternative =~ s/3//) {
            $match = ($header->rcode eq 'NXDOMAIN');
            next unless ($match);
         }
         if ($alternative =~ s/4//) {
            $match = ($header->rcode eq 'NOTIMP');
            next unless ($match);
         }
         if ($alternative =~ s/5//) {
            $match = ($header->rcode eq 'REFUSED');
            next unless ($match);
         }
         if ($alternative =~ s/TC//) {
            $match = $header->tc;
            next unless ($match);
         }
         if ($alternative =~ s/RD//) {
            $match = $header->rd;
            next unless ($match);
         }
         if ($alternative =~ s/AA//) {
            $match = $header->aa;
            next unless ($match);
         }
         if ($alternative =~ s/Z0//) {
            $match = $header->z0;
            next unless ($match);
         }
         if ($alternative =~ s/Z1//) {
            $match = $header->z1;
            next unless ($match);
         }
         if ($alternative =~ s/Z2//) {
            $match = $header->z2;
            next unless ($match);
         }
         if ($alternative =~ s/q//) {
            $match = ($#queries == -1);
            next unless ($match);
         }
         if ($alternative =~ s/Q2//) {
            $match = ($#queries == 1);
            next unless ($match);
         }
         if ($alternative =~ s/X//) {
            $match = 1;
            next unless ($match);
         }
         if ($alternative =~ s/D//) {
            $match = ($#answers > -1);
            next unless ($match);
         }
      }

      return $match;
   }

1;

# ---------------------------------------------------------------------------------

use strict;

if ($#ARGV != 0) {
   print "usage: $0 <hostname>\n\n";
   exit 1;
}

my $targethost = $ARGV[0];

my $map = MapTool->new($targethost);

$map->probe();
$map->results();