package t::800_utils::Tracker::HTTP;
use Net::BitTorrent::Protocol qw[:bencode :compact]; # IPv6
use Moo;
use AnyEvent::Socket;
use Test::More;
#
extends 't::800_utils::Tracker';
sub _build_socket {
my $s = shift;
my $x = tcp_server(
$s->host,
$s->port,
sub {
my ($fh, $paddr, $host, $port) = @_;
my $hdl;
$hdl = AnyEvent::Handle->new(
fh => $fh,
on_drain => sub {
$s->on_drain($hdl, $fh, $paddr, $host, $port, @_);
},
on_read => sub {
$s->on_read($hdl, $fh, $paddr, $host, $port, @_);
},
on_eof => sub { note 'bye!' }
);
},
sub {
$s->_set_host($_[1]);
$s->_set_port($_[2]);
1;
}
);
}
sub on_read {
my ($s, $h, $fh, $ip, $port) = @_;
my ($status, $body) = ('404 EH!?', 'Sorry. Play again.');
if ($h->rbuf =~ s[^GET (.+?)(?:\?(.+))? HTTP/1\.(\d)\015\012][]) {
my ($path, $args, $ver) = ($1, $2, $3);
my %args = map { m[^(.+?)(?:=(.*))?$]; $1 => $2; }
split qr[[&;]], $args;
my %headers = map { m[^(.+?)\s*:\s*(.+)$]; $1 => $2; }
split qr[\015\012], $h->rbuf;
if ($path eq '/announce.pl') {
my $tracker_id = $args{'tracker id'} // pack 'H*', int rand(time);
my $max_peers = $args{'max_peers'} // 50;
my $info_hash = uc $args{'info_hash'};
my $event = $args{'event'} // '';
$info_hash =~ s[%(..)][chr hex $1]eg;
$s->complete($s->complete + 1) if $event eq 'complete';
my $_id = pack('H*', $args{'key'} // '') ^ $info_hash ^
pack('B*', $args{'peer_id'});
$s->peers->{$_id} = {
address => [$args{'ip'} // $ip, $args{'port'} // $port],
downloaded => $args{'downloaded'},
event => $event,
info_hash => $info_hash,
key => $args{'key'} // $_id,
left => $args{'left'},
peer_id => $args{'peer_id'},
tracker_id => $tracker_id,
uploaded => $args{'uploaded'},
touch => time
};
$status = '200 Alright';
my $num_peers = 0;
my @peers = grep {
$_->{'info_hash'} eq $info_hash
&& $num_peers++ < $max_peers
} values %{$s->peers};
$body = {
complete => $s->complete,
incomplete => ((scalar @peers) - $s->complete),
'min interval' => int($s->interval / 2),
interval => $s->interval,
'tracker id' => $tracker_id,
peers => (
$args{'compact'}
?
(compact_ipv4 map { $_->{'address'} } @peers)
: (map {
{peer_id => $_->{'peer_id'},
ip => $_->{'address'}->[0],
port => $_->{'address'}->[1]
}
} @peers
)
)
};
}
elsif ($path eq '/scrape.pl') { note 'Scrape!' }
else { note 'NFI!' }
}
$h->rbuf = '';
$body = bencode $body if ref $body;
$h->push_write(sprintf
<<'END', $status, length($body), $body); $h->push_shutdown
HTTP/1.0 %s
Content-Type: text/plain
Content-Length: %d
Connection: close
%s
END
}
1;
=pod
=head1 Author
Sanko Robinson <sanko@cpan.org> - http://sankorobinson.com/
CPAN ID: SANKO
=head1 License and Legal
Copyright (C) 2008-2013 by Sanko Robinson <sanko@cpan.org>
This program is free software; you can redistribute it and/or modify it under
the terms of
L<The Artistic License 2.0|http://www.perlfoundation.org/artistic_license_2_0>.
See the F<LICENSE> file included with this distribution or
L<notes on the Artistic License 2.0|http://www.perlfoundation.org/artistic_2_0_notes>
for clarification.
When separated from the distribution, all original POD documentation is
covered by the
L<Creative Commons Attribution-Share Alike 3.0 License|http://creativecommons.org/licenses/by-sa/3.0/us/legalcode>.
See the
L<clarification of the CCA-SA3.0|http://creativecommons.org/licenses/by-sa/3.0/us/>.
Neither this module nor the L<Author|/Author> is affiliated with BitTorrent,
Inc.
=for rcs $Id$
=cut