File Coverage

blib/lib/Net/Gnutella/Connection.pm
Criterion Covered Total %
statement 45 349 12.8
branch 0 190 0.0
condition 0 28 0.0
subroutine 15 33 45.4
pod 0 12 0.0
total 60 612 9.8


line stmt bran cond sub pod time code
1             package Net::Gnutella::Connection;
2 1     1   506 use Net::Gnutella::Packet::Ping;
  1         2  
  1         23  
3 1     1   584 use Net::Gnutella::Packet::Pong;
  1         3  
  1         27  
4 1     1   556 use Net::Gnutella::Packet::Push;
  1         3  
  1         31  
5 1     1   633 use Net::Gnutella::Packet::Query;
  1         3  
  1         27  
6 1     1   460 use Net::Gnutella::Packet::Reply;
  1         2  
  1         25  
7 1     1   437 use Net::Gnutella::Event;
  1         2  
  1         28  
8 1     1   903 use HTTP::Request;
  1         657452  
  1         34  
9 1     1   1052 use HTTP::Date;
  1         233051  
  1         86  
10 1     1   1047 use HTTP::Status;
  1         7621  
  1         430  
11 1     1   1407 use LWP::MediaTypes qw(guess_media_type);
  1         26756  
  1         1016  
12 1     1   4032 use URI::URL;
  1         4230  
  1         64  
13 1     1   882 use IO::File;
  1         2209  
  1         144  
14 1     1   9 use Carp qw(carp croak confess);
  1         2  
  1         45  
15 1     1   5 use strict;
  1         2  
  1         46  
16 1     1   5 use vars qw/$VERSION $AUTOLOAD/;
  1         2  
  1         4821  
17            
18             $VERSION = $VERSION = "0.1";
19            
20             # Use AUTOHANDLER to supply generic attribute methods
21             #
22             sub AUTOLOAD {
23 0     0     my $self = shift;
24 0           my $attr = $AUTOLOAD;
25 0           $attr =~ s/.*:://;
26 0 0         return unless $attr =~ /[^A-Z]/; # skip DESTROY and all-cap methods
27 0 0         confess sprintf "invalid attribute method: %s->%s()", ref($self), $attr unless exists $self->{_attr}->{lc $attr};
28 0 0         $self->{_attr}->{lc $attr} = shift if @_;
29 0           return $self->{_attr}->{lc $attr};
30             }
31            
32             sub disconnect {
33 0     0 0   my ($self, $type) = @_;
34            
35 0 0         printf STDERR "+ Disconnecting socket (%s)\n", $type if $self->debug;
36            
37 0 0         if ($type) {
38 0           my $event = Net::Gnutella::Event->new(
39             from => $self,
40             type => $type,
41             );
42            
43 0           $self->parent->_handler($event);
44             }
45            
46 0           $self->parent->_remove_fh($self->socket, "rw");
47 0           $self->readbuf("");
48 0           $self->writebuf("");
49 0           $self->connected(0);
50 0           $self->socket("");
51             }
52            
53             # ->forward( PACKET [, REPLY_PATH ] )
54             #
55             # Composes the packet and delivers it to all other ESTABLISHED connections
56             #
57             sub forward {
58 0     0 0   my ($self, $packet, $path) = @_;
59            
60 0 0 0       unless ($packet && ref $packet) {
61 0           carp "Invalid argument to Net::Gnutella::Connection->forward";
62             }
63            
64 0           my $data = $packet->format;
65 0           my $head = pack("L4CCCL", @{ $packet->msgid }, $packet->function, $packet->ttl, $packet->hops, length $data);
  0            
66            
67 0 0         if ($path) {
68 0 0         if ($path ne $self) {
69 0 0         printf STDERR " - Returning down path to %s\n", $path->ip if $self->debug >= 2;
70            
71 0           $path->_write_wrapper($head.$data);
72             }
73             } else {
74 0           foreach my $conn ($self->parent->connections) {
75 0 0         next if $conn eq $self;
76 0 0         next unless $conn->connected;
77            
78 0 0         printf STDERR " - Forwarding to %s\n", $conn->ip if $self->debug >= 2;
79            
80 0           $conn->_write_wrapper($head.$data);
81             }
82             }
83             }
84            
85 0     0 0   sub is_outgoing { $_[0]->connected == 1 } # Outgoing
86 0     0 0   sub is_incoming { $_[0]->connected == 2 } # Incoming
87 0     0 0   sub is_established { $_[0]->connected == 3 } # Gnutella DATA Stream
88 0     0 0   sub is_http { $_[0]->connected == 4 } # HTTP Serving
89 0     0 0   sub is_upload { $_[0]->connected == 5 } # Sending file
90            
91             sub new {
92 0     0 0   my $proto = shift;
93 0           my $parent = shift;
94 0           my %args = @_;
95            
96 0           my $self = {
97             _handler => {},
98             _attr => {
99             parent => $parent,
100             debug => $parent->debug,
101             timeout => $parent->timeout,
102             socket => undef,
103             ip => '',
104             connected => 0,
105             readbuf => '',
106             writebuf => '',
107             error => '',
108             allow => 0,
109             msgid => [],
110             },
111             _msgid => {},
112             };
113            
114 0           bless $self, $proto;
115            
116 0           foreach my $key (keys %args) {
117 0           my $lkey = lc $key;
118            
119 0           $self->$lkey($args{$key});
120             }
121            
122 0 0 0       if ($self->connected and $self->socket) {
123 0           $self->parent->_add_fh($self->socket, $self->can("_read_socket"), "r", $self);
124             }
125            
126 0           return $self;
127             }
128            
129             sub send_error {
130 0     0 0   my ($self, $status, $error) = @_;
131            
132 0 0         unless ($self->is_http) {
133 0           croak "Invalid state for ->send_error";
134             }
135            
136 0   0       $status ||= RC_BAD_REQUEST;
137 0   0       $error ||= "";
138            
139 0           my $message = status_message($status);
140 0           my $CRLF = "\r\n";
141            
142 0           my $ip = "Unknown";
143 0           my $port = "Unknown";
144            
145 0           my $body = <
146            
147            
148             $status $message
149            
150            

$message

151             $error

152            
Net::Gnutella $VERSION Server at $ip Port $port
153            
154             EOT
155            
156 0           my $head;
157 0           $head .= sprintf "%s %s %s%s", "HTTP/1.0", $status, $message, $CRLF;
158 0           $head .= sprintf "Date: %s%s", time2str(time), $CRLF;
159 0           $head .= sprintf "Server: %s/%s%s", "Net-Gnutella", $VERSION, $CRLF;
160 0           $head .= sprintf "Content-Type: %s%s", "text/html", $CRLF;
161 0           $head .= sprintf "Content-Length: %s%s", length($body), $CRLF;
162 0           $head .= sprintf "%s", $CRLF;
163            
164 0           $self->_write_wrapper($head.$body);
165            
166 0           return;
167             }
168            
169             sub send_file {
170 0     0 0   my ($self, $file, $offset) = @_;
171            
172 0 0         unless ($self->is_http) {
173 0           croak "Invalid state for ->send_file";
174             }
175            
176 0 0         if (-f $file) {
177 0           my ($ct, $ce) = guess_media_type($file);
178 0           my ($size, $mtime) = (stat _)[7,9];
179            
180 0 0         my $fh = new IO::File $file or
181             return $self->send_error(RC_FORBIDDEN);
182            
183 0           binmode($fh);
184            
185 0 0 0       if ($offset && $offset > $size) {
    0          
186 0           $offset = 0;
187             } elsif ($offset) {
188 0 0         $fh->seek($offset, 0) or $offset = 0;
189             }
190            
191 0 0         my $status = $offset ? RC_PARTIAL_CONTENT : RC_OK;
192 0           my $message = status_message($status);
193 0           my $CRLF = "\r\n";
194            
195 0           my $head;
196 0           $head .= sprintf "%s %s %s%s", "HTTP/1.0", $status, $message, $CRLF;
197 0           $head .= sprintf "Date: %s%s", time2str(time), $CRLF;
198 0           $head .= sprintf "Server: %s/%s%s", "Net-Gnutella", $VERSION, $CRLF;
199 0           $head .= sprintf "Content-Type: %s%s", $ct, $CRLF;
200 0 0         $head .= sprintf "Content-Encoding: %s%s", $ce, $CRLF if $ce;
201 0 0         $head .= sprintf "Content-Length: %d%s", $offset ? $size - $offset : $size, $CRLF if $size;
    0          
202 0 0         $head .= sprintf "Content-Range: bytes %d-%d/%d%s", $offset, $size-1, $size, $CRLF if $offset;
203 0 0         $head .= sprintf "Last-Modified: %s%s", time2str($mtime), $CRLF if $mtime;
204 0           $head .= sprintf "%s", $CRLF;
205            
206 0           $self->_write_wrapper($head, $fh);
207 0           $self->connected(5);
208             } else {
209 0           return $self->send_error(RC_NOT_FOUND);
210             }
211            
212 0           return 1;
213             }
214            
215             sub send_packet {
216 0     0 0   my ($self, $packet) = @_;
217            
218 0 0         unless ($self->is_established) {
219 0           croak "Invalid state for ->send_packet";
220             }
221            
222 0 0 0       unless ($packet && ref $packet) {
223 0           carp "Invalid argument to Net::Gnutella::Connection->send_packet";
224             }
225            
226 0 0         printf STDERR "+ Sending packet '%s'\n", ref($packet) if $self->debug >= 2;
227            
228 0           my @msgid = @{ $packet->msgid };
  0            
229            
230 0 0         unless (scalar @msgid) {
231 0           @msgid = $self->_new_msgid;
232             }
233            
234 0           my $data = $packet->format;
235 0           my $head = pack("L4CCCL", @msgid, $packet->function, $packet->ttl, $packet->hops, length $data);
236            
237 0           $self->parent->_msgid_source(\@msgid, $self);
238            
239 0           $self->_write_wrapper($head.$data);
240            
241 0           return \@msgid;
242             }
243            
244             sub send_page {
245 0     0 0   my ($self, $data) = @_;
246            
247 0 0         unless ($self->is_http) {
248 0           croak "Invalid state in ->send_page";
249             }
250            
251 0           my $status = RC_OK;
252 0           my $message = status_message($status);
253 0           my $CRLF = "\r\n";
254            
255 0           my $head;
256 0           $head .= sprintf "%s %s %s%s", "HTTP/1.0", $status, $message, $CRLF;
257 0           $head .= sprintf "Date: %s%s", time2str(time), $CRLF;
258 0           $head .= sprintf "Server: %s/%s%s", "Net-Gnutella", $VERSION, $CRLF;
259 0           $head .= sprintf "Content-Type: %s%s", "text/html", $CRLF;
260 0           $head .= sprintf "Content-Length: %d%s", length($data), $CRLF;
261 0           $head .= sprintf "%s", $CRLF;
262            
263 0           $self->_write_wrapper($head.$data);
264             }
265            
266             sub _default {
267 0     0     my $self = shift;
268 0           my $event = shift;
269            
270 0           my $type = $event->type;
271 0           my $packet = $event->packet;
272            
273 0 0         printf STDERR "%s->%s: Handling event '%s'\n", ref($self), "_default", $type if $self->debug;
274            
275 0 0 0       unless ($packet and ref($packet) =~ /^Net::Gnutella::Packet::/) {
276 0           return 1;
277             }
278            
279 0 0         if ($packet->hops > 7) {
280 0 0         printf STDERR "+ Not forwarding, large hop count (%s)\n", $packet->hops if $self->debug;
281 0           return 1;
282             }
283            
284 0 0         if ($packet->ttl > 50) {
285 0 0         printf STDERR "+ Not forwarding, large ttl (%s)\n", $packet->ttl if $self->debug;
286 0           return 1;
287             }
288            
289 0 0         if ($packet->ttl > 7) {
290 0           $packet->ttl(7);
291             }
292            
293 0 0         if ($packet->ttl <= 0) {
294 0 0         printf STDERR "+ Not forwarding, ttl <= 0 (%s)\n", $packet->ttl if $self->debug;
295 0           return 1;
296             } else {
297 0           $packet->ttl($packet->ttl - 1);
298 0           $packet->hops($packet->hops + 1);
299             }
300            
301 0 0         if ($type eq "pong") {
302 0           $self->parent->_host_cache( join(":", $packet->ip_as_string, $packet->port) );
303             }
304            
305             # Drop any routed replies which we haven't seen
306             # Drop any duplicate packets
307             #
308 0 0         if ($type =~ /^(ping|query|push)$/) {
    0          
309 0 0         if ($self->parent->_msgid_source($packet->msgid)) {
310 0           return; # duplicate
311             } else {
312 0           $self->parent->_msgid_source($packet->msgid, $self);
313             }
314             } elsif ($type =~ /^(pong|reply)$/) {
315 0 0         unless ($self->parent->_msgid_source($packet->msgid)) {
316 0 0         printf STDERR "+ Not forwarding, unseen msgid to routed type (%s)\n", join(":", @{$packet->msgid}) if $self->debug;
  0            
317 0           return;
318             }
319             }
320            
321             # If the packet is a routed reply (pong and reply) and it didn't originate
322             # from this connection, forward it to the other connection.
323             #
324             # Otherwise, throw it at all the connections (broadcast).
325             #
326 0 0         if ($type =~ /^(pong|reply)$/) {
    0          
327 0           my $conn = $self->parent->_msgid_source($packet->msgid);
328            
329 0           $self->forward($packet, $conn);
330             } elsif ($type =~ /^(ping|push|query)$/) {
331 0           $self->forward($packet);
332             }
333            
334 0           return 1;
335             }
336            
337             sub _new_msgid {
338 0     0     my $self = shift;
339 0           my $msgid = $self->msgid;
340            
341 0 0         if (scalar @$msgid) {
342 0           $self->msgid([ $msgid->[0], $msgid->[1], $msgid->[2], ++$msgid->[3] ]);
343             } else {
344 0           $msgid = [ int rand(65536**2), int rand(65536**2), int rand(65536**2), int rand(65536**2) ];
345            
346 0           $self->msgid($msgid);
347             }
348            
349 0 0         return wantarray ? @$msgid : $msgid;
350             }
351            
352             sub _read_socket {
353 0     0     my $self = shift;
354 0           my $buf = $self->readbuf;
355            
356 0           local $SIG{PIPE} = 'IGNORE';
357            
358 0 0         if ($self->is_outgoing) {
    0          
    0          
359 0           my $ret = $self->socket->sysread($buf, 13, length $buf);
360            
361 0 0         if ($ret == 0) {
362 0           $self->disconnect;
363 0           return;
364             }
365            
366 0           $self->readbuf($buf);
367            
368 0 0         if ($buf eq "GNUTELLA OK\n\n") {
369 0           $self->readbuf("");
370 0           $self->connected(3); # ESTABLISHED
371            
372 0           my $event = Net::Gnutella::Event->new(
373             from => $self,
374             type => "connected",
375             );
376            
377 0           $self->parent->_handler($event);
378            
379 0           return;
380             }
381            
382 0 0         if (length $buf >= 13) {
383 0           $self->error("Invalid response");
384 0           $self->disconnect;
385 0           return;
386             }
387             } elsif ($self->is_incoming) {
388 0           my $ret = $self->socket->sysread($buf, 1, length $buf);
389            
390 0 0         if ($ret == 0) {
391 0           $self->disconnect;
392 0           return;
393             }
394            
395 0           $self->readbuf($buf);
396            
397 0 0         if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
    0          
    0          
398 0 0         if ($buf =~ /\015?\012\015?\012/) {
    0          
399 0 0         unless ($self->allow & 2) {
400 0           $self->disconnect;
401 0           return;
402             }
403            
404 0           $self->readbuf("");
405 0           $self->connected(4); # HTTP
406            
407 0 0         unless ($buf =~ s/^(\w+)[ \t]+(.+)[ \t]+(HTTP\/\d+\.\d+)[^\012]*\012//) {
408 0           $self->send_error(400); # BAD_REQUEST
409 0           $self->error("Bad request line");
410 0           return;
411             }
412            
413 0           my $url = URI::URL->new($2);
414 0           my $request = HTTP::Request->new($1, $url);
415            
416 0           my ($key, $val);
417            
418 0           HEADER: while ($buf =~ s/^([^\012]*)\012//) {
419 0           $_ = $1;
420 0           s/\015$//;
421            
422 0 0         if (/^([\w\-]+)\s*:\s*(.*)/) {
    0          
423 0 0         $request->push_header($key, $val) if $key;
424 0           ($key, $val) = ($1, $2);
425             } elsif (/^\s+(.*)/) {
426 0           $val .= " $1";
427             } else {
428 0           last HEADER;
429             }
430             }
431            
432 0 0         $request->push_header($key, $val) if $key;
433            
434 0           my $event = Net::Gnutella::Event->new(
435             from => $self,
436             type => "download_req",
437             packet => $request,
438             );
439            
440 0           $self->parent->_handler($event);
441            
442 0           return;
443             } elsif (length($buf) > 1*1024) {
444 0           $self->disconnect;
445 0           $self->error("Very long header");
446 0           return;
447             }
448             } elsif ($buf =~ /^GNUTELLA CONNECT\/(\d+\.\d+)\015?\012\015?\012/) {
449 0 0         if ($1 le "0.4") {
450 0 0         unless ($self->allow & 1) {
451 0           $self->disconnect;
452 0           return;
453             }
454            
455 0           $self->readbuf("");
456 0           $self->connected(3); # ESTABLISHED
457            
458 0           $self->_write_wrapper("GNUTELLA OK\n\n");
459            
460 0           my $event = Net::Gnutella::Event->new(
461             from => $self,
462             type => "connected",
463             );
464            
465 0           $self->parent->_handler($event);
466            
467 0           return;
468             } else {
469 0           $self->disconnect;
470 0           return;
471             }
472             } elsif (length($buf) > 1*1024) {
473 0           $self->disconnect;
474 0           $self->error("Very long first line");
475 0           return;
476             }
477             } elsif ($self->is_established) {
478 0           my $ret = $self->socket->sysread($buf, 256, length $buf);
479            
480 0 0         if ($ret == 0) {
481 0           $self->disconnect("disconnect");
482 0           return;
483             }
484            
485 0           $self->readbuf($buf);
486            
487 0 0         printf STDERR " - Read %d bytes, buffer has %d bytes\n", $ret, length $buf if $self->debug;
488            
489             PROCESS: {
490 0 0         if (length $buf < 23) {
  0            
491 0           last PROCESS;
492             }
493            
494 0           my @msgid = unpack("L4", substr($buf, 0, 16));
495 0           my $func = unpack("C", substr($buf, 16, 1));
496 0           my $ttl = unpack("C", substr($buf, 17, 1));
497 0           my $hops = unpack("C", substr($buf, 18, 1));
498 0           my $len = unpack("L", substr($buf, 19, 4));
499            
500 0 0         if (length($buf) < 23+$len) {
501 0           last PROCESS;
502             }
503            
504 0           my $head = substr($buf, 0, 23, '');
505 0           my $data = substr($buf, 0, $len, '');
506            
507 0 0         printf STDERR " - Full packet read, %d bytes left\n", length $buf if $self->debug;
508            
509 0           my $class;
510            
511 0 0         if ($func == 0) {
    0          
    0          
    0          
    0          
512 0 0         goto PROCESS if $len != 0;
513 0           $class = "Net::Gnutella::Packet::Ping";
514             } elsif ($func == 1) {
515 0 0         goto PROCESS if $len != 14;
516 0           $class = "Net::Gnutella::Packet::Pong";
517             } elsif ($func == 64) {
518 0 0         goto PROCESS if $len != 26;
519 0           $class = "Net::Gnutella::Packet::Push";
520             } elsif ($func == 128) {
521 0 0         goto PROCESS if $len >= 257;
522 0           $class = "Net::Gnutella::Packet::Query";
523             } elsif ($func == 129) {
524 0 0         goto PROCESS if $len >= 67_075;
525 0           $class = "Net::Gnutella::Packet::Reply";
526             } else {
527 0           goto PROCESS;
528             }
529            
530 0           my $packet = $class->new(
531             Msgid => \@msgid,
532             Function => $func,
533             TTL => $ttl,
534             Hops => $hops,
535             Parse => $data,
536             );
537            
538 0           my $event = Net::Gnutella::Event->new(
539             from => $self,
540             type => $func,
541             packet => $packet,
542             );
543            
544 0           $self->parent->_handler($event);
545            
546 0           goto PROCESS;
547             }
548            
549 0 0         printf STDERR " - buffer has %d bytes\n\n", length $buf if $self->debug;
550            
551 0           $self->readbuf($buf);
552             } else {
553 0           my $ret = $self->socket->sysread($buf, 16*1024, length($buf));
554            
555 0 0         if ($self->is_upload) {
556 0           $self->disconnect("upload_error");
557             } else {
558 0           $self->disconnect;
559             }
560             }
561            
562 0           return;
563             }
564            
565             sub _write_socket {
566 0     0     my ($self, $sock, $fh) = @_;
567 0           my $buf = $self->writebuf;
568            
569 0           local $SIG{PIPE} = 'IGNORE';
570            
571 0 0         printf STDERR " - Writing to FH, bytes in buffer: %s\n", length($buf) if $self->debug;
572            
573 0 0         if (length($buf) == 0) {
574 0           return;
575             }
576            
577 0           my $len = $self->socket->syswrite($buf, length $buf);
578            
579 0 0         if ($len == 0) {
580 0           $self->disconnect;
581 0           return;
582             }
583            
584 0           substr($buf, 0, $len, '');
585            
586 0 0         printf STDERR " - Wrote %d bytes, %d bytes left\n", $len, length($buf) if $self->debug;
587            
588 0 0 0       if ($self->is_upload and defined $fh) {
589 0           printf "Buf length %d, pos %d\n", length $buf, tell($fh);
590 0           my $read = sysread($fh, $buf, (16*1024)-length($buf), length($buf));
591 0           printf "Reading [%s] [%d] [%d]\n", $fh, $read, tell($fh);
592             }
593            
594 0           $self->writebuf($buf);
595            
596 0 0         if (length($buf)) {
597 0           return;
598             }
599            
600 0           $self->parent->_remove_fh($self->socket, "w");
601            
602 0 0 0       if ($self->is_upload and $fh and ref($fh) eq "IO::File") {
    0 0        
603 0           $self->disconnect("download_complete");
604             } elsif ($self->is_http) {
605 0           $self->disconnect;
606             }
607             }
608            
609             sub _write_wrapper {
610 0     0     my ($self, $data, @args) = @_;
611 0           my $buf = $self->writebuf;
612            
613 0           $self->writebuf($buf.$data);
614 0           $self->parent->_add_fh($self->socket, $self->can("_write_socket"), "w", $self, @args);
615             }
616            
617             1;