diff --git a/lib/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm index 922013e2..4f46f3f0 100644 --- a/lib/HTTP/Daemon.pm +++ b/lib/HTTP/Daemon.pm @@ -107,8 +107,8 @@ sub get_request } $self->reason(""); - my $buf = ${*$self}{'httpd_rbuf'}; - $buf = "" unless defined $buf; + my $buf = \${*$self}{'httpd_rbuf'}; + $$buf = "" unless defined $$buf; my $timeout = $ {*$self}{'io_socket_timeout'}; my $fdset = ""; @@ -118,13 +118,13 @@ sub get_request READ_HEADER: while (1) { # loop until we have the whole header in $buf - $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines - if ($buf =~ /\012/) { # potential, has at least one line - if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) { - if ($buf =~ /\015?\012\015?\012/) { + $$buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines + if ($$buf =~ /\012/) { # potential, has at least one line + if ($$buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) { + if ($$buf =~ /\015?\012\015?\012/) { last READ_HEADER; # we have it } - elsif (length($buf) > 16*1024) { + elsif (length($$buf) > 16*1024) { $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE $self->reason("Very long header"); return; @@ -134,18 +134,19 @@ sub get_request last READ_HEADER; # HTTP/0.9 client } } - elsif (length($buf) > 16*1024) { + elsif (length($$buf) > 16*1024) { $self->send_error(414); # REQUEST_URI_TOO_LARGE $self->reason("Very long first line"); return; } print STDERR "Need more data for complete header\n" if $DEBUG; - return unless $self->_need_more($buf, $timeout, $fdset); + my $got_more = $self->_need_more($$buf, $timeout, $fdset); + return $got_more unless $got_more; } - if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { + if ($$buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); $self->send_error(400); # BAD_REQUEST - $self->reason("Bad request line: $buf"); + $self->reason("Bad request line: $$buf"); return; } my $method = $1; @@ -162,7 +163,7 @@ sub get_request # we expect to find some headers my($key, $val); HEADER: - while ($buf =~ s/^([^\012]*)\012//) { + while ($$buf =~ s/^([^\012]*)\012//) { $_ = $1; s/\015$//; if (/^([^:\s]+)\s*:\s*(.*)/) { @@ -189,7 +190,7 @@ sub get_request } if ($only_headers) { - ${*$self}{'httpd_rbuf'} = $buf; + ${*$self}{'httpd_rbuf'} = $$buf; return $r; } @@ -217,7 +218,7 @@ sub get_request CHUNK: while (1) { print STDERR "Chunked\n" if $DEBUG; - if ($buf =~ s/^([^\012]*)\012//) { + if ($$buf =~ s/^([^\012]*)\012//) { my $chunk_head = $1; unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) { $self->send_error(400); @@ -227,21 +228,22 @@ sub get_request my $size = hex($1); last CHUNK if $size == 0; - my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end + my $missing = $size - length($$buf) + 2; # 2=CRLF at chunk end # must read until we have a complete chunk while ($missing > 0) { print STDERR "Need $missing more bytes\n" if $DEBUG; - my $n = $self->_need_more($buf, $timeout, $fdset); - return unless $n; - $missing -= $n; + my $got_more = $self->_need_more($$buf, $timeout, $fdset); + return $got_more unless $got_more; + $missing -= $got_more; } - $body .= substr($buf, 0, $size); - substr($buf, 0, $size+2) = ''; + $body .= substr($$buf, 0, $size); + substr($$buf, 0, $size+2) = ''; } else { # need more data in order to have a complete chunk header - return unless $self->_need_more($buf, $timeout, $fdset); + my $got_more = $self->_need_more($$buf, $timeout, $fdset); + return $got_more unless $got_more; } } $r->content($body); @@ -253,12 +255,13 @@ sub get_request my($key, $val); FOOTER: while (1) { - if ($buf !~ /\012/) { + if ($$buf !~ /\012/) { # need at least one line to look at - return unless $self->_need_more($buf, $timeout, $fdset); + my $got_more = $self->_need_more($$buf, $timeout, $fdset); + return $got_more unless $got_more; } else { - $buf =~ s/^([^\012]*)\012//; + $$buf =~ s/^([^\012]*)\012//; $_ = $1; s/\015$//; if (/^([\w\-]+)\s*:\s*(.*)/) { @@ -288,20 +291,20 @@ sub get_request } elsif ($len) { # Plain body specified by "Content-Length" - my $missing = $len - length($buf); + my $missing = $len - length($$buf); while ($missing > 0) { print "Need $missing more bytes of content\n" if $DEBUG; - my $n = $self->_need_more($buf, $timeout, $fdset); - return unless $n; - $missing -= $n; + my $got_more = $self->_need_more($$buf, $timeout, $fdset); + return $got_more unless $got_more; + $missing -= $got_more; } - if (length($buf) > $len) { - $r->content(substr($buf,0,$len)); - substr($buf, 0, $len) = ''; + if (length($$buf) > $len) { + $r->content(substr($$buf,0,$len)); + substr($$buf, 0, $len) = ''; } else { - $r->content($buf); - $buf=''; + $r->content($$buf); + $$buf=''; } } elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) { @@ -309,17 +312,17 @@ sub get_request my $boundary = "$CRLF--$2--"; my $index; while (1) { - $index = index($buf, $boundary); + $index = index($$buf, $boundary); last if $index >= 0; # end marker not yet found - return unless $self->_need_more($buf, $timeout, $fdset); + my $got_more = $self->_need_more($$buf, $timeout, $fdset); + return $got_more unless $got_more; } $index += length($boundary); - $r->content(substr($buf, 0, $index)); - substr($buf, 0, $index) = ''; + $r->content(substr($$buf, 0, $index)); + substr($$buf, 0, $index) = ''; } - ${*$self}{'httpd_rbuf'} = $buf; $r; } @@ -335,12 +338,14 @@ sub _need_more my $n = select($fdset,undef,undef,$timeout); unless ($n) { $self->reason(defined($n) ? "Timeout" : "select: $!"); + return 0 if defined($n); # Recoverable: return defined false return; } } print STDERR "sysread()\n" if $DEBUG; my $n = sysread($self, $_[0], 2048, length($_[0])); $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; + return unless $n; $n; } @@ -733,11 +738,13 @@ of C. The following methods are provided: =item $c->get_request( $headers_only ) This method reads data from the client and turns it into an -C object which is returned. It returns C -if reading fails. If it fails, then the C -object ($c) should be discarded, and you should not try call this -method again on it. The $c->reason method might give you some -information about why $c->get_request failed. +C object which is returned. It returns a false, but +defined, value if it failed because of a read timeout; in this case, +repeated calls to $c->get_request may eventually succeed. +It returns undef it it fails because of another reason; in this case, +the C object ($c) should be discarded, and you +should not try call this method again on it. The $c->reason method +might give you some information about why $c->get_request failed. The get_request() method will normally not return until the whole request has been received from the client. This might not be what you @@ -758,7 +765,7 @@ Bytes read by $c->get_request, but not used are placed in the I. The next time $c->get_request is called it will consume the bytes in this buffer before reading more data from the network connection itself. The read buffer is invalid after $c->get_request -has failed. +has failed, except for time outs. If you handle the reading of the request content yourself you need to empty this buffer before you read more and you need to place diff --git a/t/timeout.t b/t/timeout.t new file mode 100644 index 00000000..ba28df91 --- /dev/null +++ b/t/timeout.t @@ -0,0 +1,98 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Config; +use HTTP::Daemon; +use Test::More; +# use Time::HiRes qw(sleep); +our $CRLF; +use Socket qw($CRLF); + +my $can_fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); + +my $tport = 8333; + +my $tsock = IO::Socket::INET->new(LocalAddr => '0.0.0.0', + LocalPort => $tport, + Listen => 1, + ReuseAddr => 1); +if (!$can_fork) { + plan skip_all => "This system cannot fork"; +} +elsif (!$tsock) { + plan skip_all => "Cannot listen on 0.0.0.0:$tport"; +} +else { + close $tsock; + plan tests => 2; +} + +sub mywarn ($) { + my($mess) = @_; + open my $fh, ">>", "http-daemon.out" + or die $!; + my $ts = localtime; + print $fh "$ts: $mess\n"; + close $fh or die $!; +} + + +my $pid; +if ($pid = fork) { + sleep 1; + use IO::Socket::INET; + my $sock = IO::Socket::INET->new( + PeerAddr => "127.0.0.1", + PeerPort => $tport, + ) or die; + print $sock "GET / HTTP/1.1\r\n"; + sleep 3; + print $sock "Host: 127.0.0.1\r\n\r\n"; + local $/; + my $resp = <$sock>; + close $sock; + my($got) = $resp =~ /\r?\n\r?\nretries=(\d+)/s; + ok($got, "Trickled request works"); + is($got, "4", "get_request timed 4 times"); + wait; +} else { + die "cannot fork: $!" unless defined $pid; + my $d = HTTP::Daemon->new( + LocalAddr => '0.0.0.0', + LocalPort => $tport, + ReuseAddr => 1, + ) or die; + mywarn "Starting new daemon as '$$'"; + my $i; + LISTEN: while (my $c = $d->accept) { + $c->timeout(.6); + my $retries = 0; + my $r; + TRY: { + $r = $c->get_request; + if (defined $r and not $r) { + $retries++; + mywarn "Retry $retries"; + redo TRY; + } + } + mywarn sprintf "headers[%s] content[%s]", $r->headers->as_string, $r->content; + my $res = HTTP::Response->new(200,undef,undef,"retries=$retries"); + $c->send_response($res); + $c->force_last_request; # we're just not mature enough + $c->close; + undef($c); + last; + } +} + + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 2 +# End: