[Catalyst-commits] r7465 - in trunk/Catalyst-Engine-HTTP-Prefork: lib/Catalyst/Engine/HTTP lib/Catalyst/Engine/HTTP/Prefork t

andyg at dev.catalyst.perl.org andyg at dev.catalyst.perl.org
Mon Mar 3 15:51:19 GMT 2008


Author: andyg
Date: 2008-03-03 15:51:18 +0000 (Mon, 03 Mar 2008)
New Revision: 7465

Added:
   trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Restarter.pm
   trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_request_absolute.t
   trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_response_100continue.t
Modified:
   trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork.pm
   trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Handler.pm
   trunk/Catalyst-Engine-HTTP-Prefork/t/testapp_prefork.pl
Log:
HTTP::Prefork, added some more 1.1 tests, restart support, docs

Modified: trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Handler.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Handler.pm	2008-03-02 23:03:20 UTC (rev 7464)
+++ trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Handler.pm	2008-03-03 15:51:18 UTC (rev 7465)
@@ -133,12 +133,20 @@
     push @headers, "$protocol $status $message";
     
     # Switch on Transfer-Encoding: chunked if we don't know Content-Length.
-    if ( $protocol eq 'HTTP/1.1' && !$c->response->content_length ) {
-        if ( $c->response->status !~ /^1\d\d|[23]04$/ ) {
-            DEBUG && warn "[$$] Using chunked transfer-encoding to send unknown length body\n";
-            $c->response->header( 'Transfer-Encoding' => 'chunked' );
-            $self->{_chunked_res} = 1;
+    if ( $protocol eq 'HTTP/1.1' ) {
+        if ( !$c->response->content_length ) {
+            if ( $c->response->status !~ /^1\d\d|[23]04$/ ) {
+                DEBUG && warn "[$$] Using chunked transfer-encoding to send unknown length body\n";
+                $c->response->header( 'Transfer-Encoding' => 'chunked' );
+                $self->{_chunked_res} = 1;
+            }
         }
+        elsif ( my $te = $c->response->header('Transfer-Encoding') ) {
+            if ( $te eq 'chunked' ) {
+                DEBUG && warn "[$$] Chunked transfer-encoding set for response\n";
+                $self->{_chunked_res} = 1;
+            }
+        }
     }
     
     if ( !$c->response->header('Date') ) {

Added: trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Restarter.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Restarter.pm	                        (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Restarter.pm	2008-03-03 15:51:18 UTC (rev 7465)
@@ -0,0 +1,53 @@
+package Catalyst::Engine::HTTP::Prefork::Restarter;
+
+use strict;
+
+use Catalyst::Engine::HTTP::Restarter::Watcher;
+use File::Spec;
+
+use constant DEBUG => $ENV{CATALYST_PREFORK_DEBUG} || 0;
+
+sub init {
+    my ( $class, $options ) = @_;
+    
+    if ( my $pid = fork ) {
+        DEBUG && warn "Restarting: Running ($pid)\n";
+        return;
+    }
+    
+    $0 .= ' [Prefork::Restarter]';
+    
+    # Prepare
+    close STDIN;
+    close STDOUT;
+
+    my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
+        directory       => ( 
+            $options->{restart_directory} || 
+            File::Spec->catdir( $FindBin::Bin, '..' )
+        ),
+        follow_symlinks => $options->{follow_symlinks},
+        regex           => $options->{restart_regex},
+        delay           => $options->{restart_delay},
+    );
+    
+    while (1) {
+        # poll for changed files    
+        my @changed_files = $watcher->watch();
+
+        # check if our parent process has died
+        exit if $^O ne 'MSWin32' and getppid == 1;
+        
+        # Restart if any files have changed
+        if (@changed_files) {
+            my $files = join ', ', @changed_files;
+            print STDERR qq/File(s) "$files" modified, restarting\n\n/;
+            
+            kill HUP => getppid;
+            
+            exit;
+        }
+    }
+}
+
+1;
\ No newline at end of file


Property changes on: trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork/Restarter.pm
___________________________________________________________________
Name: svn:keywords
   + Id

Modified: trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork.pm	2008-03-02 23:03:20 UTC (rev 7464)
+++ trunk/Catalyst-Engine-HTTP-Prefork/lib/Catalyst/Engine/HTTP/Prefork.pm	2008-03-03 15:51:18 UTC (rev 7465)
@@ -11,13 +11,14 @@
 use IO::Select;
 use IO::Socket qw(:crlf);
 use Perlbal::XS::HTTPHeaders;
-use Perlbal::HTTPHeaders;
 use Socket;
 
 use constant DEBUG        => $ENV{CATALYST_PREFORK_DEBUG} || 0;
 use constant CHUNKSIZE    => 64 * 1024;
 use constant READ_TIMEOUT => 5;
 
+our $VERSION = '0.01';
+
 sub run {
     my ( $self, $class, $port, $host, $options ) = @_;
     
@@ -29,18 +30,32 @@
     my $engine = Catalyst::Engine::HTTP::Prefork::Handler->new( $self->{server} );
     $self->{appclass}->engine( $engine );
     
+    # Restore ARGV since Getopt has eaten it and Net::Server needs it
+    # for proper restart support
+    @ARGV = @{ $options->{argv} };
+    
     $self->SUPER::run(
-        port      => $port || 3000,
-        host      => $host || '*',
-        serialize => 'flock',
-        log_level => DEBUG ? 4 : 1,
-        # XXX: allow customizing of prefork settings
+        port              => $port || 3000,
+        host              => $host || '*',
+        serialize         => 'flock',
+        log_level         => DEBUG ? 4 : 1,
+        min_servers       => $options->{min_servers}       || 5,
+        min_spare_servers => $options->{min_spare_servers} || 2,
+        max_spare_servers => $options->{max_spare_servers} || 10,
+        max_servers       => $options->{max_servers}       || 50,
+        max_reqeusts      => $options->{max_requests}      || 1000,
     );
 }
 
 sub pre_loop_hook {
     my $self = shift;
     
+    # Init watcher process if necessary
+    if ( $self->{options}->{restart} ) {
+        require Catalyst::Engine::HTTP::Prefork::Restarter;
+        Catalyst::Engine::HTTP::Prefork::Restarter->init( $self->{options} );
+    }
+    
     my $host = $self->{server}->{host}->[0];
     my $port = $self->{server}->{port}->[0];
     
@@ -119,8 +134,6 @@
             if $headers->{'X-Forwarded-For'};
         $ENV{HTTP_X_FORWARDED_HOST} = $headers->{'X-Forwarded-Host'} 
             if $headers->{'X-Forwarded-Host'};
-        $ENV{HTTP_HOST}             = $headers->{Host}
-            if $headers->{Host};
     
         # Determine whether we will keep the connection open after the request
         my $connection = $headers->{Connection};
@@ -141,6 +154,36 @@
                 # Keep-alive assumed in HTTP/1.1
                 $self->{client}->{keepalive} = 1;
             }
+            
+            # Do we need to send 100 Continue?
+            if ( $headers->{Expect} ) {
+                if ( $headers->{Expect} eq '100-continue' ) {
+                    syswrite STDOUT, 'HTTP/1.1 100 Continue' . $CRLF . $CRLF;
+                    DEBUG && warn "[$$] Sent 100 Continue response\n";
+                }
+                else {
+                    DEBUG && warn "[$$] Invalid Expect header, returning 417\n";
+                    $self->_http_error( 417, 'HTTP/1.1' );
+                    last;
+                }
+            }
+            
+            # Check for an absolute request and determine the proper Host value
+            if ( $ENV{PATH_INFO} =~ /^http/i ) {
+                my ($host, $path) = $ENV{PATH_INFO} =~ m{^http://([^/]+)(/.+)}i;
+                $ENV{HTTP_HOST} = $host;
+                $ENV{PATH_INFO} = $path;
+                DEBUG && warn "[$$] Absolute path request, host: $host, path: $path\n";
+            }
+            elsif ( $headers->{Host} ) {
+                $ENV{HTTP_HOST} = $headers->{Host};
+            }
+            else {
+                # No host, bad request
+                DEBUG && warn "[$$] Bad request, HTTP/1.1 without Host header\n";
+                $self->_http_error( 400, 'HTTP/1.1' );
+                last;
+            }
         }
     
         # Pass flow control to Catalyst
@@ -234,12 +277,12 @@
 }
 
 sub _http_error {
-    my ( $self, $code, $reason ) = @_;
+    my ( $self, $code, $protocol, $reason ) = @_;
     
     my $status   = $code || 500;
     my $message  = status_message($status);
     my $response = HTTP::Response->new( $status => $message );
-    $response->protocol( 'HTTP/1.0' );
+    $response->protocol( $protocol || 'HTTP/1.0' );
     $response->content_type( 'text/plain' );
     $response->header( Connection => 'close' );
     $response->date( time() );
@@ -247,8 +290,11 @@
     if ( !$reason ) {
         $reason = $message;
     }
+    
+    my $msg = "$status $reason";
 
-    $response->content( "$status $reason" );
+    $response->content_length( length($msg) );
+    $response->content( $msg );
 
     syswrite STDOUT, $response->as_string($CRLF);
 }
@@ -256,3 +302,105 @@
 1;
 __END__
 
+=head1 NAME
+
+Catalyst::Engine::HTTP::Prefork - High-performance pre-forking Catalyst engine
+
+=head1 SYNOPIS
+
+    CATALYST_ENGINE='HTTP::Prefork' script/yourapp_server.pl
+
+=head1 DESCRIPTION
+
+This engine is designed to run as a standalone Catalyst server, without
+requiring the use of another web server.  It's goals are high-performance,
+HTTP/1.1 compliance, and robustness.  It is also suitable for use as a
+faster development server with support for automatic restarting.
+
+This engine is designed to replace the L<Catalyst::Engine::HTTP::POE> engine,
+which is now deprecated.
+
+=head1 RESTART SUPPORT
+
+This engine supports the same restart options as L<Catalyst::Engine::HTTP>.
+The server may also be restarted by sending it a HUP signal.
+
+=head1 HTTP/1.1 support
+
+This engine fully supports the following HTTP/1.1 features:
+
+=head2 Chunked Requests
+
+Chunked body data is handled transparently by L<HTTP::Body>.
+
+=head2 Chunked Responses
+
+By setting the Transfer-Encoding header to 'chunked', you can indicate you
+would like the response to be sent to the client as a chunked response.  Also,
+any responses without a content-length will be sent chunked.
+
+=head2 Pipelined Requests
+
+Browsers sending any number of pipelined requests will be handled properly.
+
+=head2 Keep-Alive
+
+Keep-alive is supported for both HTTP/1.1 (by default) and HTTP/1.0 (if a
+Connection: keep-alive header is present in the request).
+
+=head1 CUSTOMIZATION
+
+Additional options may be passed to the engine by modifying
+yourapp_server.pl to send additional items to the run() method.
+
+=head2 min_servers
+
+The minimum number of servers to keep running.  Defaults to 5.
+
+=head2 min_spare_servers
+
+The minimum number of servers to have waiting for requests. Minimum and
+maximum numbers should not be set too close to each other or the server will
+fork and kill children too often.  Defaults to 2.
+
+=head2 max_spare_servers
+
+The maximum number of servers to have waiting for requests.  Defaults to 10.
+
+=head2 max_servers
+
+The maximum number of child servers to start.  Defaults to 50.
+
+=head2 max_requests
+
+Restart a child after it has served this many requests.  Defaults to 1000.
+Note that setting this value to 0 will not cause the child to serve unlimited
+requests.  This is a limitation of Net::Server and may be fixed in a future
+version.
+
+=head1 PERFORMANCE
+
+Benchmarks were performend on all the HTTP engines serving the Catalyst
+welcome message, which is about 5.5K of data.  These numbers are from my
+2Ghz Core Duo MacBook Pro.
+
+    Engine           Req/s [1]   [2]   [3]
+    ------------------------------------------
+    HTTP
+    HTTP::POE
+    HTTP::Prefork
+    
+[1] ab -n 10000 -c 1 -k
+[2] ab -n 10000 -c 5 -k
+[3] ab -n 10000 -c 10 -k
+
+=head1 AUTHOR
+
+Andy Grundman, <andy at hybridized.org>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
\ No newline at end of file

Added: trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_request_absolute.t
===================================================================
--- trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_request_absolute.t	                        (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_request_absolute.t	2008-03-03 15:51:18 UTC (rev 7465)
@@ -0,0 +1,81 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 4;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use Data::Dump qw(dump);
+use IO::Select;
+use IO::Socket qw(:crlf);
+use IO::Socket::INET;
+use HTTP::Response;
+use URI;
+
+my $server = URI->new( $ENV{CATALYST_SERVER} || 'http://localhost' );
+my $base   = $server->host . ':' . $server->port;
+
+# Test absolute request
+{
+    my $sock = IO::Socket::INET->new(
+        PeerAddr  => $server->host,
+        PeerPort  => $server->port,
+        Proto     => 'tcp',
+        ReuseAddr => 1,
+        Timeout   => 2,
+    ) or die "Cannot connect to $server";
+    
+    # Send request
+    syswrite $sock, construct_request( "http://$base/dump/request", 'foo.bar.com:3000' );
+    
+    # Read/parse response
+    sysread $sock, my $buf, 64 * 1024;
+    my $response = HTTP::Response->parse($buf);
+    
+    is( $response->code, 200, 'Response ok' );
+    
+    my $creq;    
+    ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+    
+    like( $creq->base, qr/$base/, 'base uses host from absolute request' );
+}
+
+# Test normal request without Host header
+{
+    my $sock = IO::Socket::INET->new(
+        PeerAddr  => $server->host,
+        PeerPort  => $server->port,
+        Proto     => 'tcp',
+        ReuseAddr => 1,
+        Timeout   => 2,
+    ) or die "Cannot connect to $server";
+    
+    # Send request
+    syswrite $sock, construct_request( "/dump/request" );
+    
+    # Read/parse response
+    sysread $sock, my $buf, 64 * 1024;
+    my $response = HTTP::Response->parse($buf);
+    
+    is( $response->code, 400, 'Invalid response ok' );
+}
+
+sub construct_request {
+    my ( $url, $host ) = @_;
+    
+    my $req 
+        = 'GET ' . $url . ' HTTP/1.1' . $CRLF;
+    
+    if ( $host ) {
+        $req .= 'Host: foo.bar.com:3000' . $CRLF;
+    }
+    
+    $req .= $CRLF;
+    
+    return $req;
+}
\ No newline at end of file


Property changes on: trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_request_absolute.t
___________________________________________________________________
Name: svn:keywords
   + Id

Added: trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_response_100continue.t
===================================================================
--- trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_response_100continue.t	                        (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_response_100continue.t	2008-03-03 15:51:18 UTC (rev 7465)
@@ -0,0 +1,125 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 10;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use Data::Dump qw(dump);
+use IO::Select;
+use IO::Socket qw(:crlf);
+use IO::Socket::INET;
+use HTTP::Response;
+use URI;
+
+my $server = URI->new( $ENV{CATALYST_SERVER} || 'http://localhost' );
+my $base   = $server->host . ':' . $server->port;
+
+# Test 100-continue with HTTP/1.1 request
+{
+    my $sock = IO::Socket::INET->new(
+        PeerAddr  => $server->host,
+        PeerPort  => $server->port,
+        Proto     => 'tcp',
+        ReuseAddr => 1,
+        Timeout   => 2,
+    ) or die "Cannot connect to $server";
+    
+    # Send request
+    syswrite $sock, construct_request( "http://$base/dump/request", '1.1', '100-continue' );
+    
+    # Read/parse response
+    sysread $sock, my $buf, 64 * 1024;
+    
+    like( $buf, qr{^HTTP/1.1 100 Continue}, '100 Continue ok' );
+    
+    # Continue sending a POST body
+    syswrite $sock, 'one=foo&two=bar';
+    
+    # Read/parse response
+    sysread $sock, $buf, 64 * 1024;
+    my $response = HTTP::Response->parse($buf);
+    
+    is( $response->code, 200, 'Response ok' );
+    
+    my $creq;
+    my $expected = {
+        one => 'foo',
+        two => 'bar',
+    };
+    
+    ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+    is( $creq->method, 'POST', 'Request method is POST' );
+    is_deeply( $creq->{parameters}, $expected, 'Parameters ok' );
+}
+
+# Test invalid Expect header
+{
+    my $sock = IO::Socket::INET->new(
+        PeerAddr  => $server->host,
+        PeerPort  => $server->port,
+        Proto     => 'tcp',
+        ReuseAddr => 1,
+        Timeout   => 2,
+    ) or die "Cannot connect to $server";
+    
+    # Send request
+    syswrite $sock, construct_request( "http://$base/dump/request", '1.1', '200-bleh' );
+    
+    # Read/parse response
+    sysread $sock, my $buf, 64 * 1024;
+    
+    like( $buf, qr{^HTTP/1.1 417}, 'Invalid expect returned 417' );    
+}
+
+# Test Expect header with HTTP/1.0
+{
+    my $sock = IO::Socket::INET->new(
+        PeerAddr  => $server->host,
+        PeerPort  => $server->port,
+        Proto     => 'tcp',
+        ReuseAddr => 1,
+        Timeout   => 2,
+    ) or die "Cannot connect to $server";
+    
+    # Send request
+    syswrite $sock, construct_request( "http://$base/dump/request", '1.0', '100-continue' );
+    
+    # Continue sending a POST body
+    syswrite $sock, 'one=foo&two=bar';
+    
+    # Read/parse response
+    sysread $sock, my $buf, 64 * 1024;
+    my $response = HTTP::Response->parse($buf);
+    
+    is( $response->code, 200, 'Response ok' );    
+    
+    my $creq;
+    my $expected = {
+        one => 'foo',
+        two => 'bar',
+    };
+    
+    ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+    is( $creq->method, 'POST', 'Request method is POST' );
+    is_deeply( $creq->{parameters}, $expected, 'Parameters ok' );
+}
+
+sub construct_request {
+    my ( $url, $protocol, $expect ) = @_;
+    
+    my $uri = URI->new($url);
+    my $req 
+        = 'POST ' . $uri->path_query . ' HTTP/' . $protocol . $CRLF
+        . 'Host: ' . $uri->host . ':' . $uri->port . $CRLF
+        . 'Content-Type: application/x-www-form-urlencoded' . $CRLF
+        . 'Content-Length: 15' . $CRLF
+        . 'Expect: ' . $expect . $CRLF . $CRLF;
+    
+    return $req;
+}
\ No newline at end of file


Property changes on: trunk/Catalyst-Engine-HTTP-Prefork/t/live_http11_response_100continue.t
___________________________________________________________________
Name: svn:keywords
   + Id

Modified: trunk/Catalyst-Engine-HTTP-Prefork/t/testapp_prefork.pl
===================================================================
--- trunk/Catalyst-Engine-HTTP-Prefork/t/testapp_prefork.pl	2008-03-02 23:03:20 UTC (rev 7464)
+++ trunk/Catalyst-Engine-HTTP-Prefork/t/testapp_prefork.pl	2008-03-03 15:51:18 UTC (rev 7465)
@@ -10,18 +10,28 @@
 use FindBin;
 use lib "$FindBin::Bin/../lib";
 
-my $debug         = 0;
-my $help          = 0;
-my $host          = undef;
-my $port          = 3000;
+my $debug             = 0;
+my $help              = 0;
+my $host              = undef;
+my $port              = 3000;
+my $restart           = 0;
+my $restart_delay     = 1;  
+my $restart_regex     = '(?:/|^)(?!\.#).+(?:\.yml$|\.yaml$|\.pm)$';
+my $restart_directory = undef;
+my $follow_symlinks   = 0;
 
 my @argv = @ARGV;
 
 GetOptions(
-    'debug|d'           => \$debug,
-    'help|?'            => \$help,
-    'host=s'            => \$host,
-    'port=s'            => \$port,
+    'debug|d'             => \$debug,
+    'help|?'              => \$help,
+    'host=s'              => \$host,
+    'port=s'              => \$port,
+    'restart|r'           => \$restart,
+    'restartdelay|rd=s'   => \$restart_delay,
+    'restartregex|rr=s'   => \$restart_regex,
+    'restartdirectory=s@' => \$restart_directory,
+    'followsymlinks'      => \$follow_symlinks,
 );
 
 pod2usage(1) if $help;
@@ -35,7 +45,12 @@
 require TestApp;
 
 TestApp->run( $port, $host, {
-    argv => \@argv,
+    argv              => \@argv,
+    restart           => $restart,
+    restart_delay     => $restart_delay,
+    restart_regex     => qr/$restart_regex/,
+    restart_directory => $restart_directory,
+    follow_symlinks   => $follow_symlinks,
 } );
 
 1;




More information about the Catalyst-commits mailing list