BitTorrent/TestTool

This quick and nasty hack will examine all the torrents available on a tracker and check it can actually talk to the seeds/peers. You can use it from, say, a machine outside your firewall to make sure your seeds are actually visible through NAT and the like and to help narrow down problems a little.

It works with the toothycat.net AMV tracker at the time of writing; MoonShadow hasn't tested it with anything else. As written, it'll hammer the tracker pretty hard, so please only use on your own trackers.


#! perl -w
use strict;

my $myPeerID = '01234567890123456789'; # todo: generate this pseudorandomly

# ----------------------------------------------------
my $usage = <<'END'

Usage:
 perl btconntest.pl 'tracker url'

END
;

use IO::Socket;
use URI::Escape;
use LWP::UserAgent;

my $tracker = '';
my $UA = LWP::UserAgent->new();


sub GET
{
	my ($x) = @_;

	my @getargs = $x;

	my $response = $UA->get(@getargs);
	if ($response->is_success)
	{
		return $response->content;
	}
	print $response->status_line;
	return '';
}

sub bdecode
{
  my ($x) = @_;

	if( $x =~ /^d/s )
	{
		$x = substr($x, 1);
		my %result;
		while( length($x) && !($x =~ /^e/s) )
		{
		  my $key;
			my $elt;
			($key, $x) = bdecode( $x );
			($elt, $x) = bdecode( $x );
			$result{$$key} = $elt;
		}
		return( \%result, substr($x, 1) );
	}
	elsif( $x =~ /^i([0-9-]+)e/s )
	{
		return (\substr($x, 1, length($1)), substr($x, length($1)+2));
	}
	elsif( $x =~ /^l/s )
	{
		$x = substr($x, 1);
		my @result;
		while( length($x) && !($x =~ /^e/s) )
		{
		  my $elt;
			($elt, $x) = bdecode( $x );
			push @result, $elt;
		}
		return( \@result, substr($x, 1) );
	}
	elsif( $x =~ /^([0-9]+):/s )
	{
	  $x = substr($x, length($1) + 1);
		return (\substr($x, 0, $1), substr($x, $1));
	}

	die("Invalid bdecode prefix: '$x'\n");
}

sub Bin
{
	my ($info_hash) = @_;
	return pack('H*', $info_hash);
}

sub Handshake
{
	my($peer, $port, $info_hash, $peer_ID) = @_;
	my $sock = IO::Socket::INET->new(   
						Proto     => "tcp",
						PeerAddr  => $peer,
						PeerPort  => $port
					) or return 0;

	print $sock chr(19) . 'BitTorrent protocol' . (chr(0) x 8) . $info_hash . $myPeerID;

	my $x = '';
	my $len = ''; 
	my $ok = read($sock, $len, 1);
	$ok and $ok = read($sock, $x, unpack('c', $len));

	if( $ok and ( $x ne 'BitTorrent protocol' ) )
	{
		print " - using unknown protocol: $x";
	}

	$ok and $ok = read($sock, $x, 8);		# reserved bytes
	$ok and $ok = read($sock, $x, 20);	# info hash
	if( $ok and ( $info_hash ne $x ) )
	{
		print " - info_hash " . unpack('H*', $x) . " doesn't match tracker";
	}

	$ok and $ok = read($sock, $x, 20);	# peer ID
	if( $ok and ( $peer_ID ne $x ) )
	{
		print " - peer ID " . unpack('H*', $x) . " doesn't match tracker";
	}

	$sock->shutdown(2);

	return $ok;
}

sub Scrape
{
	my ($scrape, $left) = bdecode( GET($tracker.'scrape') );

	if($scrape->{files})
	{
		foreach my $file( keys %{$scrape->{files}} )
		{
			print unpack('H*' , $file) . "\n";
			TryPeers( $file );
		}
	}
}

sub TryPeers
{
  my($hash) = @_;
	my $rq = 'announce?';
	$rq .= 'info_hash=' . uri_escape($hash) . '&';
	$rq .= 'peer_id=' . $myPeerID . '&';
	$rq .= 'port=6881&uploaded=0&downloaded=0&left=999999&numwant=30';

	my $result = GET($tracker.$rq.'&event=started');
	my $left = GET($tracker.$rq.'&event=stopped');
	( $result, $left ) = bdecode( $result );

	if( defined( $result->{peers} ) )
	{
		foreach my $peer( @{$result->{peers}} )
		{
			print 'Peer: ';
			print ${$peer->{'peer id'}};
			print ' ';
			print ${$peer->{'ip'}};
			print ':';
			print ${$peer->{'port'}};
			if( Handshake( ${$peer->{'ip'}}, ${$peer->{'port'}}, $hash, ${$peer->{'peer id'}} ) )
			{
				print " - OK\n";
			}
			else
			{
				print " - N/A\n";
			}
			print "\n";
		}
	}
	else
	{
		print "Tracker didn't send any peers.\n";
	}

	print "\n";
}

if( $#ARGV != 0 )
{
	die ($usage);
}

$tracker = $ARGV[0];
if( !($tracker =~ /^http:\/\//i) )
{
	$tracker = 'http://' . $tracker;
}

if( !($tracker =~/\/$/) )
{
	$tracker = $tracker . '/';
}

Scrape();