From: Andy Grundman <andy@hybridized.org>
Date: Fri, 9 Mar 2007 19:01:09 +0000 (+0000)
Subject: Re-enable keep-alive support in HTTP engine, with a 1-second delay
X-Git-Tag: 5.7099_04~236
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=3bcb3aae8066d3d14cdb0cea3a9e5bc794354bc7

Re-enable keep-alive support in HTTP engine, with a 1-second delay
---

diff --git a/Changes b/Changes
index b4e09ea..a17a6b4 100644
--- a/Changes
+++ b/Changes
@@ -2,7 +2,6 @@ This file documents the revision history for Perl extension Catalyst.
 
 5.7007  ??
         - Performance and stability improvements to the built-in HTTP server.
-        - Built-in server no longer supports -k (keep-alive).
         - Don't ignore file uploads if form contains a text field with the same name.
           (Carl Franks)
         - Support restart_delay of 0 (for use in the POE engine).
diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm
index e4f31f4..365249a 100644
--- a/lib/Catalyst/Engine/HTTP.pm
+++ b/lib/Catalyst/Engine/HTTP.pm
@@ -58,9 +58,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
@@ -169,6 +181,8 @@ sub run {
     my ( $self, $class, $port, $host, $options ) = @_;
 
     $options ||= {};
+    
+    $self->{options} = $options;
 
     if ($options->{background}) {
         my $child = fork;
@@ -240,20 +254,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;
@@ -333,39 +339,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;