X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP.pm;h=2a718c4177ca652d63896a587f353d7fc946d207;hb=44c6d25a7b66041252d88ea41f26631aeca30eef;hp=e4f31f41142ff88f7b846db0ffa4d296527b1dbd;hpb=4bb8bd62f620afd41160a61a2995d319779a3d99;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index e4f31f4..2a718c4 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -16,9 +16,8 @@ use IO::Select (); require Catalyst::Engine::HTTP::Restarter; require Catalyst::Engine::HTTP::Restarter::Watcher; -sub CHUNKSIZE () { 64 * 1024 } - -sub DEBUG () { $ENV{CATALYST_HTTP_DEBUG} || 0 } +use constant CHUNKSIZE => 64 * 1024; +use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; =head1 NAME @@ -58,9 +57,21 @@ sub finalize_headers { push @headers, "$protocol $status $message"; $c->response->headers->header( Date => HTTP::Date::time2str(time) ); - $c->response->headers->header( Connection => 'close' ); $c->response->headers->header( Status => $status ); + # Should we keep the connection open? + my $connection = $c->request->header('Connection'); + if ( $self->{options}->{keepalive} + && $connection + && $connection =~ /^keep-alive$/i + ) { + $c->response->headers->header( Connection => 'keep-alive' ); + $self->{_keepalive} = 1; + } + else { + $c->response->headers->header( Connection => 'close' ); + } + push @headers, $c->response->headers->as_string("\x0D\x0A"); # Buffer the headers so they are sent with the first write() call @@ -131,31 +142,29 @@ sub read_chunk { =head2 $self->write($c, $buffer) -Writes the buffer to the client. Can only be called once for a request. +Writes the buffer to the client. =cut sub write { my ( $self, $c, $buffer ) = @_; - # Avoid 'print() on closed filehandle Remote' warnings when using IE - return unless *STDOUT->opened(); - - my $ret; - - # Prepend the headers if they have not yet been sent - if ( my $headers = delete $self->{_header_buf} ) { - DEBUG && warn "write: Wrote headers and first chunk (" . length($headers . $buffer) . " bytes)\n"; - $ret = $self->NEXT::write( $c, $headers . $buffer ); - } - else { - DEBUG && warn "write: Wrote chunk (" . length($buffer) . " bytes)\n"; - $ret = $self->NEXT::write( $c, $buffer ); + # Avoid 'print() on closed filehandle Remote' warnings when using IE + return unless *STDOUT->opened(); + + # Prepend the headers if they have not yet been sent + if ( my $headers = delete $self->{_header_buf} ) { + $buffer = $headers . $buffer; } - if ( !$ret ) { + my $ret = $self->NEXT::write( $c, $buffer ); + + if ( !defined $ret ) { $self->{_write_error} = $!; } + else { + DEBUG && warn "write: Wrote response ($ret bytes)\n"; + } return $ret; } @@ -169,11 +178,13 @@ sub run { my ( $self, $class, $port, $host, $options ) = @_; $options ||= {}; + + $self->{options} = $options; if ($options->{background}) { my $child = fork; die "Can't fork: $!" unless defined($child); - exit if $child; + return $child if $child; } my $restart = 0; @@ -231,6 +242,12 @@ sub run { # Ignore broken pipes as an HTTP server should local $SIG{PIPE} = 'IGNORE'; + # Restart on HUP + local $SIG{HUP} = sub { + $restart = 1; + warn "Restarting server on SIGHUP...\n"; + }; + LISTEN: while ( !$restart ) { while ( accept( Remote, $daemon ) ) { @@ -240,20 +257,12 @@ sub run { Remote->blocking(1); - # Read until we see a newline + # Read until we see all headers $self->{inputbuf} = ''; - - while (1) { - my $read = sysread Remote, my $buf, CHUNKSIZE; - if ( !$read ) { - DEBUG && warn "EOF or error: $!\n"; - next LISTEN; - } - - DEBUG && warn "Read $read bytes\n"; - $self->{inputbuf} .= $buf; - last if $self->{inputbuf} =~ /(\x0D\x0A?|\x0A\x0D?)/s; + if ( !$self->_read_headers ) { + # Error reading, give up + next LISTEN; } my ( $method, $uri, $protocol ) = $self->_parse_request_line; @@ -265,17 +274,30 @@ sub run { unless ( uc($method) eq 'RESTART' ) { # Fork - if ( $options->{fork} ) { next if $pid = fork } + if ( $options->{fork} ) { + if ( $pid = fork ) { + DEBUG && warn "Forked child $pid\n"; + next; + } + } $self->_handler( $class, $port, $method, $uri, $protocol ); if ( my $error = delete $self->{_write_error} ) { DEBUG && warn "Write error: $error\n"; close Remote; - next LISTEN; + + if ( !defined $pid ) { + next LISTEN; + } } - $daemon->close if defined $pid; + if ( defined $pid ) { + # Child process, close connection and exit + DEBUG && warn "Child process exiting\n"; + $daemon->close; + exit; + } } else { my $sockdata = $self->_socket_data( \*Remote ); @@ -291,8 +313,6 @@ sub run { last; } } - - exit if defined $pid; } continue { close Remote; @@ -333,39 +353,86 @@ sub _handler { my $sel = IO::Select->new; $sel->add( \*STDIN ); + + REQUEST: + while (1) { + my ( $path, $query_string ) = split /\?/, $uri, 2; + + # Initialize CGI environment + local %ENV = ( + PATH_INFO => $path || '', + QUERY_STRING => $query_string || '', + REMOTE_ADDR => $sockdata->{peeraddr}, + REMOTE_HOST => $sockdata->{peername}, + REQUEST_METHOD => $method || '', + SERVER_NAME => $sockdata->{localname}, + SERVER_PORT => $port, + SERVER_PROTOCOL => "HTTP/$protocol", + %copy_of_env, + ); + + # Parse headers + if ( $protocol >= 1 ) { + $self->_parse_headers; + } - my ( $path, $query_string ) = split /\?/, $uri, 2; - - # Initialize CGI environment - local %ENV = ( - PATH_INFO => $path || '', - QUERY_STRING => $query_string || '', - REMOTE_ADDR => $sockdata->{peeraddr}, - REMOTE_HOST => $sockdata->{peername}, - REQUEST_METHOD => $method || '', - SERVER_NAME => $sockdata->{localname}, - SERVER_PORT => $port, - SERVER_PROTOCOL => "HTTP/$protocol", - %copy_of_env, - ); + # Pass flow control to Catalyst + $class->handle_request; + + DEBUG && warn "Request done\n"; + + # Allow keepalive requests, this is a hack but we'll support it until + # the next major release. + if ( delete $self->{_keepalive} ) { + + DEBUG && warn "Reusing previous connection for keep-alive request\n"; + + if ( $sel->can_read(1) ) { + if ( !$self->_read_headers ) { + # Error reading, give up + last REQUEST; + } - # Parse headers - if ( $protocol >= 1 ) { - $self->_parse_headers; + ( $method, $uri, $protocol ) = $self->_parse_request_line; + + DEBUG && warn "Parsed request: $method $uri $protocol\n"; + + # Force HTTP/1.0 + $protocol = '1.0'; + + next REQUEST; + } + + DEBUG && warn "No keep-alive request within 1 second\n"; + } + + last REQUEST; } - - # Pass flow control to Catalyst - $class->handle_request; - DEBUG && warn "Request done\n"; - - # XXX: We used to have a hack for keep-alive here but keep-alive - # has no place in a single-tasking server like this. Use HTTP::POE - # if you want keep-alive. + DEBUG && warn "Closing connection\n"; close Remote; } +sub _read_headers { + my $self = shift; + + while (1) { + my $read = sysread Remote, my $buf, CHUNKSIZE; + + if ( !$read ) { + DEBUG && warn "EOF or error: $!\n"; + return; + } + + DEBUG && warn "Read $read bytes\n"; + $self->{inputbuf} .= $buf; + last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s; + } + + return 1; +} + sub _parse_request_line { my $self = shift;