X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP.pm;h=808cbca4cb50e3ae1dd51a40b991315ccfd1629e;hb=00c9932455ecd6ca565d60d76180a2d850b7317b;hp=0d734567e2fd471a512c4e16b16f18a42076a56f;hpb=6dc87a0f8301391acfe25ee5bcaad0fe48dad559;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 0d73456..808cbca 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,9 +1,17 @@ package Catalyst::Engine::HTTP; use strict; -use base 'Catalyst::Engine::Test'; - -use IO::Socket qw(AF_INET INADDR_ANY SOCK_STREAM SOMAXCONN); +use base 'Catalyst::Engine::CGI'; +use Errno 'EWOULDBLOCK'; +use HTTP::Status; +use NEXT; +use Socket; +use IO::Socket::INET (); +use IO::Select (); + +# For PAR +require Catalyst::Engine::HTTP::Restarter; +require Catalyst::Engine::HTTP::Restarter::Watcher; =head1 NAME @@ -27,74 +35,379 @@ A script using the Catalyst::Engine::HTTP module might look like: This is the Catalyst engine specialized for development and testing. -=head1 OVERLOADED METHODS +=head1 METHODS + +=head2 $self->finalize_headers($c) + +=cut + +sub finalize_headers { + my ( $self, $c ) = @_; + my $protocol = $c->request->protocol; + my $status = $c->response->status; + my $message = status_message($status); + print "$protocol $status $message\015\012"; + $c->response->headers->date(time); + $c->response->headers->header( + Connection => $self->_keep_alive ? 'keep-alive' : 'close' ); + + $c->response->header( Status => $c->response->status ); + + # Avoid 'print() on closed filehandle Remote' warnings when using IE + print $c->response->headers->as_string("\015\012") if *STDOUT->opened(); + print "\015\012" if *STDOUT->opened(); +} + +=head2 $self->finalize_read($c) + +=cut + +sub finalize_read { + my ( $self, $c ) = @_; + + # Never ever remove this, it would result in random length output + # streams if STDIN eq STDOUT (like in the HTTP engine) + *STDIN->blocking(1); + + return $self->NEXT::finalize_read($c); +} + +=head2 $self->prepare_read($c) + +=cut + +sub prepare_read { + my ( $self, $c ) = @_; + + # Set the input handle to non-blocking + *STDIN->blocking(0); + + return $self->NEXT::prepare_read($c); +} + +=head2 $self->read_chunk($c, $buffer, $length) -This class overloads some methods from C. +=cut + +sub read_chunk { + my $self = shift; + my $c = shift; -=over 4 + # support for non-blocking IO + my $rin = ''; + vec( $rin, *STDIN->fileno, 1 ) = 1; -=item $c->run + READ: + { + select( $rin, undef, undef, undef ); + my $rc = *STDIN->sysread(@_); + if ( defined $rc ) { + return $rc; + } + else { + next READ if $! == EWOULDBLOCK; + return; + } + } +} + +=head2 $self->write($c, $buffer) + +Writes the buffer to the client. Can only be called once for a request. =cut -$SIG{'PIPE'} = 'IGNORE'; +sub write { + # Avoid 'print() on closed filehandle Remote' warnings when using IE + return unless *STDOUT->opened(); + + shift->NEXT::write( @_ ); +} +=head2 run + +=cut + +# A very very simple HTTP server that initializes a CGI environment sub run { - my $class = shift; - my $port = shift || 3000; + my ( $self, $class, $port, $host, $options ) = @_; + + $options ||= {}; + + if ($options->{background}) { + my $child = fork; + die "Can't fork: $!" unless defined($child); + exit if $child; + } + + my $restart = 0; + local $SIG{CHLD} = 'IGNORE'; - my $daemon = Catalyst::Engine::HTTP::Catalyst->new( + my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' }; + my $addr = $host ? inet_aton($host) : INADDR_ANY; + if ( $addr eq INADDR_ANY ) { + require Sys::Hostname; + $host = lc Sys::Hostname::hostname(); + } + else { + $host = gethostbyaddr( $addr, AF_INET ) || inet_ntoa($addr); + } + + # Handle requests + + # Setup socket + my $daemon = IO::Socket::INET->new( Listen => SOMAXCONN, + LocalAddr => inet_ntoa($addr), LocalPort => $port, + Proto => 'tcp', ReuseAddr => 1, Type => SOCK_STREAM, - ); + ) + or die "Couldn't create daemon: $!"; + + my $url = "http://$host"; + $url .= ":$port" unless $port == 80; + + print "You can connect to your server at $url\n"; + + if ($options->{background}) { + open STDIN, "+&STDIN" or die $!; + open STDERR, ">&STDIN" or die $!; + if ( $^O !~ /MSWin32/ ) { + require POSIX; + POSIX::setsid() + or die "Can't start a new session: $!"; + } + } - unless ($daemon) { - die("Failed to create daemon: $!\n"); + if (my $pidfile = $options->{pidfile}) { + if (! open PIDFILE, "> $pidfile") { + warn("Cannot open: $pidfile: $!"); + } + print PIDFILE "$$\n"; + close PIDFILE; } - my $base = URI->new( $daemon->url )->canonical; + $self->_keep_alive( $options->{keepalive} || 0 ); + + my $pid = undef; + while ( accept( Remote, $daemon ) ) + { # TODO: get while ( my $remote = $daemon->accept ) to work - printf( "You can connect to your server at %s\n", $base ); + select Remote; - while ( my $connection = $daemon->accept ) { + # Request data - $connection->timeout(5); + Remote->blocking(1); - while ( my $request = $connection->get_request ) { + next + unless my ( $method, $uri, $protocol ) = + $self->_parse_request_line( \*Remote ); - $request->uri->scheme('http'); # Force URI::http - $request->uri->host( $request->header('Host') || $base->host ); - $request->uri->port( $base->port ); + unless ( uc($method) eq 'RESTART' ) { - my $http = Catalyst::Engine::Test::HTTP->new( - address => $connection->peerhost, - hostname => gethostbyaddr( $connection->peeraddr, AF_INET ), - request => $request, - response => HTTP::Response->new - ); + # Fork + if ( $options->{fork} ) { next if $pid = fork } - $class->handler($http); - $connection->send_response( $http->response ); + $self->_handler( $class, $port, $method, $uri, $protocol ); + $daemon->close if defined $pid; + + } + else { + my $sockdata = $self->_socket_data( \*Remote ); + my $ipaddr = _inet_addr( $sockdata->{peeraddr} ); + my $ready = 0; + foreach my $ip ( keys %$allowed ) { + my $mask = $allowed->{$ip}; + $ready = ( $ipaddr & _inet_addr($mask) ) == _inet_addr($ip); + last if $ready; + } + if ($ready) { + $restart = 1; + last; + } } - $connection->close; - undef($connection); + exit if defined $pid; + } + continue { + close Remote; + } + $daemon->close; + + if ($restart) { + $SIG{CHLD} = 'DEFAULT'; + wait; + + ### if the standalone server was invoked with perl -I .. we will loose + ### those include dirs upon re-exec. So add them to PERL5LIB, so they + ### are available again for the exec'ed process --kane + use Config; + $ENV{PERL5LIB} .= join $Config{path_sep}, @INC; + + exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } ); + } + + exit; +} + +sub _handler { + my ( $self, $class, $port, $method, $uri, $protocol ) = @_; + + # Ignore broken pipes as an HTTP server should + local $SIG{PIPE} = sub { close Remote }; + + local *STDIN = \*Remote; + local *STDOUT = \*Remote; + + # We better be careful and just use 1.0 + $protocol = '1.0'; + + my $sockdata = $self->_socket_data( \*Remote ); + my %copy_of_env = %ENV; + + my $sel = IO::Select->new; + $sel->add( \*STDIN ); + + while (1) { + my ( $path, $query_string ) = split /\?/, $uri, 2; + + # Initialize CGI environment + local %ENV = ( + PATH_INFO => $path || '', + QUERY_STRING => $query_string || '', + REMOTE_ADDR => $sockdata->{peeraddr}, + REMOTE_HOST => $sockdata->{peername}, + REQUEST_METHOD => $method || '', + SERVER_NAME => $sockdata->{localname}, + SERVER_PORT => $port, + SERVER_PROTOCOL => "HTTP/$protocol", + %copy_of_env, + ); + + # Parse headers + if ( $protocol >= 1 ) { + while (1) { + my $line = $self->_get_line( \*STDIN ); + last if $line eq ''; + next + unless my ( $name, $value ) = + $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/; + + $name = uc $name; + $name = 'COOKIE' if $name eq 'COOKIES'; + $name =~ tr/-/_/; + $name = 'HTTP_' . $name + unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/; + if ( exists $ENV{$name} ) { + $ENV{$name} .= "; $value"; + } + else { + $ENV{$name} = $value; + } + } + } + + # Pass flow control to Catalyst + $class->handle_request; + + my $connection = lc $ENV{HTTP_CONNECTION}; + last + unless $self->_keep_alive() + && index( $connection, 'keep-alive' ) > -1 + && index( $connection, 'te' ) == -1 # opera stuff + && $sel->can_read(5); + + last + unless ( $method, $uri, $protocol ) = + $self->_parse_request_line( \*STDIN ); + } + + close Remote; +} + +sub _keep_alive { + my ( $self, $keepalive ) = @_; + + my $r = $self->{_keepalive} || 0; + $self->{_keepalive} = $keepalive if defined $keepalive; + + return $r; + +} + +sub _parse_request_line { + my ( $self, $handle ) = @_; + + # Parse request line + my $line = $self->_get_line($handle); + return () + unless my ( $method, $uri, $protocol ) = + $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/; + return ( $method, $uri, $protocol ); +} + +sub _socket_data { + my ( $self, $handle ) = @_; + + my $remote_sockaddr = getpeername($handle); + my ( undef, $iaddr ) = $remote_sockaddr + ? sockaddr_in($remote_sockaddr) + : (undef, undef); + + my $local_sockaddr = getsockname($handle); + my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr); + + # This mess is necessary to keep IE from crashing the server + my $data = { + peername => $iaddr + ? ( gethostbyaddr( $iaddr, AF_INET ) || 'localhost' ) + : 'localhost', + peeraddr => $iaddr + ? ( inet_ntoa($iaddr) || '127.0.0.1' ) + : '127.0.0.1', + localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost', + localaddr => inet_ntoa($localiaddr) || '127.0.0.1', + }; + + return $data; +} + +sub _get_line { + my ( $self, $handle ) = @_; + + my $line = ''; + + while ( sysread( $handle, my $byte, 1 ) ) { + last if $byte eq "\012"; # eol + $line .= $byte; } + + 1 while $line =~ s/\s\z//; + + return $line; } -=back +sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } =head1 SEE ALSO -L, L. +L, L. + +=head1 AUTHORS + +Sebastian Riedel, + +Dan Kubb, + +Sascha Kiefer, -=head1 AUTHOR +=head1 THANKS -Sebastian Riedel, C -Christian Hansen, C +Many parts are ripped out of C by Jesse Vincent. =head1 COPYRIGHT @@ -103,13 +416,4 @@ the same terms as Perl itself. =cut -package Catalyst::Engine::HTTP::Catalyst; - -use strict; -use base 'HTTP::Daemon'; - -sub product_tokens { - "Catalyst/$Catalyst::VERSION"; -} - 1;