+#! /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;
+