[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