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=95fa59743adc379ea6f9be821936573a138b4931;hb=21465c884872c1ec8c30acd72796445f9eaacb31;hpb=b333ca6bc3db5fed3310074236b8ff2b1ad2a81b diff --git a/lib/Catalyst/Engine/HTTP/Daemon.pm b/lib/Catalyst/Engine/HTTP/Daemon.pm index 95fa597..00daf22 100644 --- a/lib/Catalyst/Engine/HTTP/Daemon.pm +++ b/lib/Catalyst/Engine/HTTP/Daemon.pm @@ -1,9 +1,34 @@ package Catalyst::Engine::HTTP::Daemon; use strict; -use base 'Catalyst::Engine::Test'; +use base 'Catalyst::Engine::HTTP::Base'; -use IO::Socket qw(AF_INET); +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 @@ -15,9 +40,7 @@ A script using the Catalyst::Engine::HTTP::Daemon module might look like: #!/usr/bin/perl -w - BEGIN { - $ENV{CATALYST_ENGINE} = 'HTTP::Daemon'; - } + BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP::Daemon' } use strict; use lib '/path/to/MyApp/lib'; @@ -31,52 +54,184 @@ This is the Catalyst engine specialized for development and testing. =head1 OVERLOADED METHODS -This class overloads some methods from C. +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; + $SIG{'PIPE'} = 'IGNORE'; + my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new( + Listen => SOMAXCONN, LocalPort => $port, - ReuseAddr => 1 + ReuseAddr => 1, + 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); + } - while ( my $request = $connection->get_request ) { + else { + next if $client->request; + next if $client->response; - $request->uri->scheme('http'); # Force URI::http - $request->uri->host( $base->host ); + my $nread = $client->sysread( my $buf, 4096 ); - my $lwp = Catalyst::Engine::Test::LWP->new( - request => $request, - address => $connection->peerhost, - hostname => gethostbyaddr( $connection->peeraddr, AF_INET ) - ); + unless ( $nread ) { - $class->handler($lwp); - $connection->send_response( $lwp->response ); + next if $! == EWOULDBLOCK; + next if $! == EINPROGRESS; + next if $! == EINTR; + + $select->remove($client); + $client->close; + + next; + } + + $client->request_buffer .= $buf; + + if ( my $request = $client->get_request ) { + $client->request = $request; + $client->timestamp = time + } + } } - $connection->close; - undef($connection); + for my $client ( $select->handles ) { + + next if $client == $daemon; + + if ( ( time - $client->timestamp ) > 60 ) { + + $select->remove($client); + $client->close; + + 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 ); + } + + 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; + } + } } } @@ -84,7 +239,8 @@ sub run { =head1 SEE ALSO -L, L. +L, L, L, +L. =head1 AUTHOR @@ -103,8 +259,52 @@ package Catalyst::Engine::HTTP::Daemon::Catalyst; use strict; use base 'HTTP::Daemon'; +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;