X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP%2FDaemon.pm;h=00daf22454918583ad5f0755ca9ada046e573ca7;hp=e4fe66a5d3ad8f8974856ea2f74a7936cd3a2f0f;hb=21465c884872c1ec8c30acd72796445f9eaacb31;hpb=834d1575575a7841c37d87969dd749149de3c96b diff --git a/lib/Catalyst/Engine/HTTP/Daemon.pm b/lib/Catalyst/Engine/HTTP/Daemon.pm index e4fe66a..00daf22 100644 --- a/lib/Catalyst/Engine/HTTP/Daemon.pm +++ b/lib/Catalyst/Engine/HTTP/Daemon.pm @@ -3,7 +3,32 @@ package Catalyst::Engine::HTTP::Daemon; use strict; use base 'Catalyst::Engine::HTTP::Base'; -use IO::Socket qw(AF_INET INADDR_ANY SOCK_STREAM SOMAXCONN); +use Catalyst::Exception; +use IO::Select; +use IO::Socket; + +BEGIN { + + if ( $^O eq 'MSWin32' ) { + + *EINTR = sub { 10004 }; + *EINPROGRESS = sub { 10036 }; + *EWOULDBLOCK = sub { 10035 }; + *F_GETFL = sub { 0 }; + *F_SETFL = sub { 0 }; + + *IO::Socket::blocking = sub { + my ( $self, $blocking ) = @_; + my $nonblocking = $blocking ? 0 : 1; + ioctl( $self, 0x8004667e, \$nonblocking ); + }; + } + + else { + Errno->require; + Errno->import( qw[EWOULDBLOCK EINPROGRESS EINTR] ); + } +} =head1 NAME @@ -33,57 +58,180 @@ This class overloads some methods from C. =over 4 -=item $c->run +=item $c->handler =cut -$SIG{'PIPE'} = 'IGNORE'; +sub handler { + my ( $class, $request, $response, $client ) = @_; + + $request->uri->scheme('http'); # Force URI::http + $request->uri->host( $request->header('Host') || $client->sockhost ); + $request->uri->port( $client->sockport ); + + my $http = Catalyst::Engine::HTTP::Base::struct->new( + address => $client->peerhost, + request => $request, + response => $response + ); + + $class->SUPER::handler($http); +} + +=item $c->run + +=cut sub run { my $class = shift; my $port = shift || 3000; - my $daemon = Catalyst::Engine::HTTP::Catalyst->new( + $SIG{'PIPE'} = 'IGNORE'; + + my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new( Listen => SOMAXCONN, LocalPort => $port, ReuseAddr => 1, - Type => SOCK_STREAM, + Timeout => 5 ); - unless ($daemon) { - die("Failed to create daemon: $!\n"); + unless ( defined $daemon ) { + + Catalyst::Exception->throw( + message => qq/Failed to create daemon. Reason: '$!'/ + ); } my $base = URI->new( $daemon->url )->canonical; printf( "You can connect to your server at %s\n", $base ); - while ( my $connection = $daemon->accept ) { + my $select = IO::Select->new($daemon); + + while (1) { + + for my $client ( $select->can_read(0.01) ) { + + if ( $client == $daemon ) { + $client = $daemon->accept; + $client->timestamp = time; + $client->blocking(0); + $select->add($client); + } + + else { + next if $client->request; + next if $client->response; + + my $nread = $client->sysread( my $buf, 4096 ); + + unless ( $nread ) { + + next if $! == EWOULDBLOCK; + next if $! == EINPROGRESS; + next if $! == EINTR; - $connection->timeout(5); + $select->remove($client); + $client->close; - while ( my $request = $connection->get_request ) { + next; + } - $request->uri->scheme('http'); # Force URI::http - $request->uri->host( $request->header('Host') || $base->host ); - $request->uri->port( $base->port ); - - my $hostname = gethostbyaddr( $connection->peeraddr, AF_INET ); + $client->request_buffer .= $buf; - my $http = Catalyst::Engine::HTTP::Base::struct->new( - address => $connection->peerhost, - hostname => $hostname || $connection->peerhost, - request => $request, - response => HTTP::Response->new - ); + if ( my $request = $client->get_request ) { + $client->request = $request; + $client->timestamp = time + } + } + } + + for my $client ( $select->handles ) { + + next if $client == $daemon; + + if ( ( time - $client->timestamp ) > 60 ) { + + $select->remove($client); + $client->close; - $class->handler($http); - $connection->send_response( $http->response ); + next; + } + next if $client->response; + next unless $client->request; + + $client->response = HTTP::Response->new; + $client->response->protocol( $client->request->protocol ); + + $class->handler( $client->request, $client->response, $client ); } - $connection->close; - undef($connection); + for my $client ( $select->can_write(0.01) ) { + + next unless $client->response; + + unless ( $client->response_buffer ) { + + $client->response->header( Server => $daemon->product_tokens ); + + my $connection = $client->request->header('Connection') || ''; + + if ( $connection =~ /Keep-Alive/i ) { + $client->response->header( 'Connection' => 'Keep-Alive' ); + $client->response->header( 'Keep-Alive' => 'timeout=60, max=100' ); + } + + if ( $connection =~ /close/i ) { + $client->response->header( 'Connection' => 'close' ); + } + + $client->response_buffer = $client->response->as_string("\x0D\x0A"); + $client->response_offset = 0; + } + + my $nwrite = $client->syswrite( $client->response_buffer, + $client->response_length, + $client->response_offset ); + + unless ( $nwrite ) { + + next if $! == EWOULDBLOCK; + next if $! == EINPROGRESS; + next if $! == EINTR; + + $select->remove($client); + $client->close; + + next; + } + + $client->response_offset += $nwrite; + + if ( $client->response_offset == $client->response_length ) { + + my $connection = $client->request->header('Connection') || ''; + my $protocol = $client->request->protocol; + my $persistent = 0; + + if ( $protocol eq 'HTTP/1.1' && $connection !~ /close/i ) { + $persistent++; + } + + if ( $protocol ne 'HTTP/1.1' && $connection =~ /Keep-Alive/i ) { + $persistent++; + } + + unless ( $persistent ) { + $select->remove($client); + $client->close; + } + + $client->response = undef; + $client->request = undef; + $client->response_buffer = undef; + } + } } } @@ -91,7 +239,7 @@ sub run { =head1 SEE ALSO -L, L, L, +L, L, L, L. =head1 AUTHOR @@ -106,15 +254,57 @@ the same terms as Perl itself. =cut -package Catalyst::Engine::HTTP::Catalyst; +package Catalyst::Engine::HTTP::Daemon::Catalyst; use strict; use base 'HTTP::Daemon'; -$HTTP::Daemon::PROTO = 'HTTP/0.9'; +sub accept { + return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client'); +} sub product_tokens { - "Catalyst/$Catalyst::VERSION"; + return "Catalyst/$Catalyst::VERSION"; +} + +package Catalyst::Engine::HTTP::Daemon::Client; + +use strict; +use base 'HTTP::Daemon::ClientConn'; + +sub request : lvalue { + my $self = shift; + ${*$self}{'request'}; +} + +sub request_buffer : lvalue { + my $self = shift; + ${*$self}{'httpd_rbuf'}; +} + +sub response : lvalue { + my $self = shift; + ${*$self}{'response'}; +} + +sub response_buffer : lvalue { + my $self = shift; + ${*$self}{'httpd_wbuf'}; +} + +sub response_length { + my $self = shift; + return length( $self->response_buffer ); +} + +sub response_offset : lvalue { + my $self = shift; + ${*$self}{'httpd_woffset'}; +} + +sub timestamp : lvalue { + my $self = shift; + ${*$self}{'timestamp'}; } 1;