[Catalyst-commits] r7054 -
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket
andyg at dev.catalyst.perl.org
andyg at dev.catalyst.perl.org
Wed Oct 24 22:27:14 GMT 2007
Author: andyg
Date: 2007-10-24 22:27:13 +0100 (Wed, 24 Oct 2007)
New Revision: 7054
Modified:
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm
Log:
Sprocket engine updates... passes most tests but fails randomly on some, maybe due to a Sprocket bug
Modified: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm 2007-10-24 20:40:29 UTC (rev 7053)
+++ trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm 2007-10-24 21:27:13 UTC (rev 7054)
@@ -11,9 +11,11 @@
use Catalyst::Engine::HTTP::Sprocket::Worker;
-sub DEBUG () { $ENV{CATALYST_POE_DEBUG} || 0 }
+sub DEBUG () { $ENV{CATALYST_POE_DEBUG} || 0 }
-sub OK() { 1 }
+my $DONE_MAGIC = 'PmlTpdeB3BGukGz8eb99Wg';
+#my $DONE_REGEX = qr{^$DONE_MAGIC (\d+)$};
+my $DONE_REGEX = qr{$DONE_MAGIC$};
sub new {
my ( $class, $config ) = @_;
@@ -21,6 +23,10 @@
# Number of children to fork
$config->{children} ||= 1;
+ # Magic string children send to notify they are done
+ # with a request
+ $config->{child_done} = $DONE_MAGIC;
+
my $self = $class->SUPER::new(
name => 'Catalyst Server',
config => $config,
@@ -33,6 +39,7 @@
sig_int
sig_child
+ dump_state
child_error
child_closed
@@ -50,8 +57,14 @@
$kernel->alias_set( "$self" );
+ # Shut down cleanly on INT
$kernel->sig( INT => 'sig_int' );
+ # dump state on USR1
+ if ( DEBUG ) {
+ $kernel->sig( USR1 => 'dump_state' );
+ }
+
# Fork child proc(s)
$self->{children} = {};
$self->{child_busy} = {};
@@ -95,11 +108,31 @@
sub sig_int {
my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
+ DEBUG && warn "SIGINT received, shutting down\n";
+
for my $child ( values %{ $self->{children} } ) {
$child->kill();
}
+
+ $kernel->sig_handled();
+
+ exit;
}
+sub sig_child {
+ my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
+
+ # XXX: remove child from children hash
+
+ $kernel->sig_handled();
+}
+
+sub dump_state {
+ my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
+
+ warn dump($self) . "\n";
+}
+
### Sprocket server methods
sub local_connected {
@@ -107,22 +140,44 @@
$self->take_connection( $con );
- #$con->set_time_out( 5 );
+ return 1;
+}
+
+sub local_disconnected {
+ my ( $self, $server, $con, $error ) = @_[ 0 .. 3 ];
- return OK;
+ if ( $error ) {
+ my ( $op, $errnum, $errstr ) = @_[ 4 .. 6 ];
+ if ( !$errnum ) {
+ DEBUG && warn "[$con] remote host closed connection, resetting child\n";
+ }
+ else {
+ DEBUG && warn "[$con] disconnected with error $error ($op, $errnum, $errstr), resetting child\n";
+ }
+
+ $con->call( 'child_reset' );
+
+ $con->close();
+ }
}
+sub local_error {
+ my ( $self, $server, $op, $errnum, $errstr ) = @_;
+
+ die "local_error: $op, $errnum, $errstr\n";
+}
+
sub local_receive {
my ( $self, $server, $con, $input ) = @_;
# If this connection is already being handled, just pass the data along
if ( my $id = $con->x->{handler_id} ) {
- DEBUG && warn "[$id] Passed along " . length($input) . " bytes of body data\n";
+ DEBUG && warn "[$con] [$id] Passed along " . length($input) . " bytes of body data\n";
$self->{children}->{ $id }->put( $input );
return 1;
}
- DEBUG && warn "local_receive: " . dump($input) . "\n";
+ DEBUG && warn "[$con] local_receive: " . dump($input) . "\n";
# Find a free child to send the request to
for my $id ( keys %{ $self->{children} } ) {
@@ -134,6 +189,9 @@
# Link this child to the connection
$con->x->{handler_id} = $id;
+ # Counter of how many bytes the child sent
+ $con->x->{sent} = 0;
+
# XXX: Static requests should be handled directly with AIO
# Pass connection info before the request
@@ -147,11 +205,13 @@
# Send the data along to the child for handling
$self->{children}->{ $id }->put( $conn . $input );
- return OK;
+ return 1;
}
# XXX: no child available to handle the request
- return;
+ warn "[$con] No child available for request\n";
+ warn dump($self) . "\n";
+ die;
}
### Child handlers
@@ -187,56 +247,52 @@
my $con = $self->{child_busy}->{ $wheel_id };
- $con->send( $input );
+ if ( !$con ) {
+ # Remote host probably closed the connection, we will just ignore further data
+ DEBUG && warn "*** Got stdout data after con was closed: " . dump($input) . "\n";
+ return;
+ }
- if ( $con->x->{length} ) {
- # Body chunk(s), count bytes sent
- my $sent = length $input;
- $con->x->{sent} += $sent;
+ if ( $input =~ s/$DONE_REGEX// ) {
+ # Send any data prior to the magic done string
+ if ( defined $input ) {
+ $con->send( $input );
+
+ if ( DEBUG ) {
+ warn "[$con] [$wheel_id] Parent sent " . length($input) . " bytes to client\n";
+ #warn dump($input) . "\n";
+ }
+ }
- DEBUG && warn "[$wheel_id] Sent $sent bytes of body data\n";
- }
- elsif ( $input =~ /Content-Length:\s+(\d+)/i ) {
- # The header chunk, remember the body length
- $con->x->{length} = $1;
- $con->x->{sent} = 0;
+ DEBUG && warn "[$con] [$wheel_id] Child done sending request, resetting\n";
+ $con->call( 'child_reset' );
- DEBUG && warn "[$wheel_id] Starting response with length: " . $con->x->{length} . "\n";
+ # XXX: keep-alive support, just close connection for now
+ $con->close();
- # Any data in this chunk past \r\n\r\n is body data
- if ( $input =~ /\x0D\x0A\x0D\x0A(.+)/s ) {
- $con->x->{sent} = length $1;
- DEBUG && warn "[$wheel_id] Sent " . $con->x->{sent} . " bytes after header\n";
- }
+ return;
}
- if ( $con->x->{length} && $con->x->{sent} >= $con->x->{length} ) {
- # All done sending the body, reset for the next request
- DEBUG && warn "[$wheel_id] Done sending " . $con->x->{sent} . " bytes, resetting\n";
-
- delete $con->x->{handler_id};
- delete $con->x->{sent};
- delete $con->x->{length};
-
- # This child is free again
- $self->{child_busy}->{ $wheel_id } = 0;
-
- # XXX: keep-alive stuff
+ $con->send( $input );
+
+ if ( DEBUG ) {
+ warn "[$con] [$wheel_id] Parent sent " . length($input) . " bytes to client\n";
+ #warn dump($input) . "\n";
}
-}
+}
sub child_stderr {
my ( $kernel, $self, $input, $wheel_id ) = @_[ KERNEL, OBJECT, ARG0, ARG1 ];
-
- DEBUG && warn "[$wheel_id] $input\n";
+
+ warn "[$wheel_id err] $input\n";
}
-sub sig_child {
- my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
+sub child_reset {
+ my ( $self, $server, $con ) = @_;
- # XXX: remove child from children hash
+ my $wheel_id = delete $con->x->{handler_id};
- $kernel->sig_handled();
+ $self->{child_busy}->{ $wheel_id } = 0;
}
1;
\ No newline at end of file
Modified: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm 2007-10-24 20:40:29 UTC (rev 7053)
+++ trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm 2007-10-24 21:27:13 UTC (rev 7054)
@@ -121,7 +121,7 @@
}
$headers->push_header( $key, $val ) if $key;
- DEBUG && warn "[$$] " . dump($headers) . "\n";
+ #DEBUG && warn "[$$] " . dump($headers) . "\n";
# Convert headers into ENV vars
$headers->scan( sub {
@@ -155,13 +155,16 @@
sub finalize_headers {
my ( $self, $c ) = @_;
- my $protocol = $c->request->protocol;
+ my $protocol = 'HTTP/1.0'; # no 1.1 support yet
my $status = $c->response->status;
my $message = status_message($status);
$self->NEXT::finalize_headers($c);
- syswrite STDOUT, "$protocol $status $message\x0D\x0A";
+ # Buffer the initial line so it's sent together with the headers
+ $self->{_header_buf}
+ = "$protocol $status $message\x0D\x0A"
+ . $self->{_header_buf};
}
sub read_chunk {
@@ -199,4 +202,14 @@
return;
}
+sub finalize_body {
+ my ( $self, $c ) = @_;
+
+ $self->NEXT::finalize_body( $c );
+
+ # We need to notify the parent when a response has finished
+ # We do this by sending a special magic string
+ syswrite STDOUT, $self->{config}->{child_done};
+}
+
1;
\ No newline at end of file
More information about the Catalyst-commits
mailing list