Initial checkin for move to Git (no prior version history available).

diff --git a/test.pl b/test.pl
new file mode 100755 (executable)
index 0000000..7699333
--- /dev/null
+++ b/test.pl
@@ -0,0 +1,123 @@
+#! /usr/bin/perl
+use Socket;
+use Convert::Bencode;
+use Data::Dumper;
+use DBI;
+use URI::Escape;
+
+my $dbh = DBI->connect("dbi:Pg:dbname=ta;host=127.0.0.1", "ta", "ta")
+       or die "db connect: " . DBI->errstr;
+
+$| = 1;
+
+$/ = "\r\n\r\n";
+my $line = <STDIN>;
+
+# connect to the tracker and tell just that
+$proto = getprotobyname('tcp');
+socket(SOCK, PF_INET, SOCK_STREAM, $proto);
+$sin = sockaddr_in(80, inet_aton("85.17.40.39"));
+connect(SOCK, $sin);
+
+my $hersockaddr    = getpeername(STDIN);
+my ($port, $iaddr) = sockaddr_in($hersockaddr);
+$iaddr = inet_ntoa($iaddr);
+
+print STDERR "LINE: $line\n";
+
+my $ih;
+if ($line =~ /info_hash=(.*?)&/) {
+       $ih = URI::Escape::uri_escape(URI::Escape::uri_unescape($1));
+       if ($line =~ /port=(\d+)&/) {
+               my $port = $1;
+
+               # add to the list of seen TG peers
+               if ($line =~ /event=stopped/) {
+                       $dbh->do('DELETE FROM ta WHERE host=? AND info_hash=?', undef,
+                               $iaddr, $ih);
+               } else {
+                       $dbh->do('INSERT INTO ta (host, port, seen, info_hash) VALUES (?,?,CURRENT_TIMESTAMP,?)', undef,
+                               $iaddr, $port, $ih);
+               }
+       }
+}
+
+$line =~ s/\r\n\r\n//s;
+$line .= "\r\nX-Forwarded-For: $iaddr\r\n\r\n";
+
+send(SOCK, $line, 0);
+
+# fetch the http header
+$/ = "\r\n\r\n";
+my $hdr = <SOCK>;
+
+# fetch the body
+$/ = undef;
+my $body = <SOCK>;
+
+my $bd = Convert::Bencode::bdecode($body);
+if (exists($bd->{'peers'})) {
+       my @allpeers = ();
+       my @tgpeers = ();
+
+       my $peers = $bd->{'peers'};
+
+       for my $i (0..(length($peers) / 6 - 1)) {
+               my $iaddr = inet_ntoa(substr($peers, ($i*6+1), 4));
+               my $p1 = ord(substr($peers, ($i*6+5), 1));
+               my $p2 = ord(substr($peers, ($i*6+6), 1));
+               my $port = ($p1 << 8) | $p2;
+
+               if ($iaddr =~ /^87\.76\./) {
+                       print STDERR "FOUND INTERNAL PEER: $iaddr\n";
+                       if (defined($ih)) {
+                               $dbh->do('INSERT INTO ta (host, port, seen, info_hash) VALUES (?,?,CURRENT_TIMESTAMP,?)', undef,
+                                       $iaddr, $port, $ih);
+                       }
+                       push @tgpeers, [ $iaddr, $port ];
+               }
+
+               push @allpeers, [ $iaddr, $port ];
+       }
+
+       # check for other peers
+       my $q = $dbh->prepare('SELECT DISTINCT ON (host) * FROM ta WHERE host<>? AND info_hash=? AND seen >= now() - INTERVAL \'1 hour 15 minutes\' ORDER BY host,seen desc');
+       $q->execute($iaddr, $ih);
+
+       while (my $ref = $q->fetchrow_hashref) {
+               push @tgpeers, [ $ref->{'host'}, $ref->{'port'} ];
+       }
+
+       if (scalar @tgpeers > 0) {
+               my $newpeers = "";
+               for my $peer (@tgpeers) {
+                       $newpeers .= inet_aton($peer->[0]);
+                       $newpeers .= chr($peer->[1] >> 8);
+                       $newpeers .= chr($peer->[1] & 0xff);
+
+                       print STDERR "Adding peer $peer->[0]:$peer->[1]\n";
+               }
+               
+               # fish in some other peers
+               my $num = (scalar @tgpeers) * 2;
+               my $i = 0;
+               while ($num > 0 && $i < scalar @allpeers) {
+                       my $iaddr = $allpeers[$i]->[0];
+                       my $port = $allpeers[$i]->[1];
+                       ++$i;
+                       next if ($iaddr =~ /^87\.76\./);
+                       --$num;
+                       
+                       $newpeers .= inet_aton($iaddr);
+                       $newpeers .= chr($port >> 8);
+                       $newpeers .= chr($port & 0xff);
+               }
+
+               $bd->{'peers'} = $newpeers;
+               print STDERR "DELIVER PEERS " . scalar @tgpeers . "\n";
+               $body = Convert::Bencode::bencode($bd);
+       }
+}
+
+print $hdr . $body;
+