X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP.pm;h=fb40d6f7233a7aa0ab1e1bb48a667f28fc8a3bbd;hp=861ec5a187e02a9258567ff712b8252f411330f8;hb=4090e3bb3fea1a73ac369250e31584d61428b808;hpb=66d9e175a28989d4454714edf2cc2dab5ad64d96 diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 861ec5a..fb40d6f 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,24 +1,23 @@ package Catalyst::Engine::HTTP; -use strict; -use base 'Catalyst::Engine'; - -use CGI::Simple::Cookie; -use Class::Struct (); -use HTTP::Headers::Util 'split_header_words'; -use HTTP::Request; -use HTTP::Response; -use IO::File; -use URI; - -__PACKAGE__->mk_accessors(qw/http/); - -Class::Struct::struct 'Catalyst::Engine::HTTP::LWP' => { - request => 'HTTP::Request', - response => 'HTTP::Response', - hostname => '$', - address => '$' -}; +use Moose; +extends 'Catalyst::Engine::CGI'; + +use Data::Dump qw(dump); +use Errno 'EWOULDBLOCK'; +use HTTP::Date (); +use HTTP::Headers; +use HTTP::Status; +use Socket; +use IO::Socket::INET (); +use IO::Select (); + +# For PAR +require Catalyst::Engine::HTTP::Restarter; +require Catalyst::Engine::HTTP::Restarter::Watcher; + +use constant CHUNKSIZE => 64 * 1024; +use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; =head1 NAME @@ -26,202 +25,525 @@ Catalyst::Engine::HTTP - Catalyst HTTP Engine =head1 SYNOPSIS -L. +A script using the Catalyst::Engine::HTTP module might look like: -=head1 DESCRIPTION + #!/usr/bin/perl -w -This Catalyst engine is meant to be subclassed. + BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' } -=head1 OVERLOADED METHODS + use strict; + use lib '/path/to/MyApp/lib'; + use MyApp; -This class overloads some methods from C. + MyApp->run; -=over 4 +=head1 DESCRIPTION + +This is the Catalyst engine specialized for development and testing. + +=head1 METHODS -=item $c->finalize_headers +=head2 $self->finalize_headers($c) =cut sub finalize_headers { - my $c = shift; - - my $status = $c->response->status || 200; - my $headers = $c->response->headers; - my $response = HTTP::Response->new( $status, undef, $headers ); - - while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) { - my $cookie = CGI::Simple::Cookie->new( - -name => $name, - -value => $cookie->{value}, - -expires => $cookie->{expires}, - -domain => $cookie->{domain}, - -path => $cookie->{path}, - -secure => $cookie->{secure} || 0 - ); - - $response->header( 'Set-Cookie' => $cookie->as_string ); + my ( $self, $c ) = @_; + my $protocol = $c->request->protocol; + my $status = $c->response->status; + my $message = status_message($status); + my $res_headers = $c->response->headers; + + my @headers; + push @headers, "$protocol $status $message"; + + $res_headers->header( Date => HTTP::Date::time2str(time) ); + $res_headers->header( Status => $status ); + + # Should we keep the connection open? + my $connection = $c->request->header('Connection'); + if ( $self->{options}->{keepalive} + && $connection + && $connection =~ /^keep-alive$/i + ) { + $res_headers->header( Connection => 'keep-alive' ); + $self->{_keepalive} = 1; } + else { + $res_headers->header( Connection => 'close' ); + } + + push @headers, $res_headers->as_string("\x0D\x0A"); - $c->http->response($response); + # Buffer the headers so they are sent with the first write() call + # This reduces the number of TCP packets we are sending + $self->{_header_buf} = join("\x0D\x0A", @headers, ''); } -=item $c->finalize_output +=head2 $self->finalize_read($c) =cut -sub finalize_output { - my $c = shift; - $c->http->response->content_ref( \$c->response->{output} ); -} +around finalize_read => sub { + # Never ever remove this, it would result in random length output + # streams if STDIN eq STDOUT (like in the HTTP engine) + *STDIN->blocking(1); + shift->(@_); +}; -=item $c->prepare_connection +=head2 $self->prepare_read($c) =cut -sub prepare_connection { - my $c = shift; - $c->req->hostname( $c->http->hostname ); - $c->req->address( $c->http->address ); -} +around prepare_read => sub { + # Set the input handle to non-blocking + *STDIN->blocking(0); + shift->(@_); +}; -=item $c->prepare_cookies +=head2 $self->read_chunk($c, $buffer, $length) =cut -sub prepare_cookies { - my $c = shift; +sub read_chunk { + my $self = shift; + my $c = shift; + + # If we have any remaining data in the input buffer, send it back first + if ( $_[0] = delete $self->{inputbuf} ) { + my $read = length( $_[0] ); + DEBUG && warn "read_chunk: Read $read bytes from previous input buffer\n"; + return $read; + } + + # support for non-blocking IO + my $rin = ''; + vec( $rin, *STDIN->fileno, 1 ) = 1; - if ( my $header = $c->http->request->header('Cookie') ) { - $c->req->cookies( { CGI::Simple::Cookie->parse($header) } ); + READ: + { + select( $rin, undef, undef, undef ); + my $rc = *STDIN->sysread(@_); + if ( defined $rc ) { + DEBUG && warn "read_chunk: Read $rc bytes from socket\n"; + return $rc; + } + else { + next READ if $! == EWOULDBLOCK; + return; + } } } -=item $c->prepare_headers +=head2 $self->write($c, $buffer) + +Writes the buffer to the client. =cut -sub prepare_headers { - my $c = shift; - $c->req->method( $c->http->request->method ); - $c->req->headers( $c->http->request->headers ); -} +around write => sub { + my $orig = shift; + my ( $self, $c, $buffer ) = @_; + + # Avoid 'print() on closed filehandle Remote' warnings when using IE + return unless *STDOUT->opened(); -=item $c->prepare_parameters + # Prepend the headers if they have not yet been sent + if ( my $headers = delete $self->{_header_buf} ) { + $buffer = $headers . $buffer; + } + + my $ret = $self->$orig($c, $buffer); + + if ( !defined $ret ) { + $self->{_write_error} = $!; + DEBUG && warn "write: Failed to write response ($!)\n"; + } + else { + DEBUG && warn "write: Wrote response ($ret bytes)\n"; + } + + return $ret; +}; + +=head2 run =cut -sub prepare_parameters { - my $c = shift; +# A very very simple HTTP server that initializes a CGI environment +sub run { + my ( $self, $class, $port, $host, $options ) = @_; - my @params = (); - my $request = $c->http->request; + $options ||= {}; + + $self->{options} = $options; + + if ($options->{background}) { + my $child = fork; + die "Can't fork: $!" unless defined($child); + return $child if $child; + } + + my $restart = 0; + local $SIG{CHLD} = 'IGNORE'; + + 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); + } - push( @params, $request->uri->query_form ); + # 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: $!"; + } + } - if ( $request->content_type eq 'application/x-www-form-urlencoded' ) { - my $uri = URI->new('http:'); - $uri->query( $request->content ); - push( @params, $uri->query_form ); + if (my $pidfile = $options->{pidfile}) { + if (! open PIDFILE, "> $pidfile") { + warn("Cannot open: $pidfile: $!"); + } + print PIDFILE "$$\n"; + close PIDFILE; } - if ( $request->content_type eq 'multipart/form-data' ) { + my $pid = undef; + + # Ignore broken pipes as an HTTP server should + local $SIG{PIPE} = 'IGNORE'; + + # Restart on HUP + local $SIG{HUP} = sub { + $restart = 1; + warn "Restarting server on SIGHUP...\n"; + }; - for my $part ( $request->parts ) { + LISTEN: + while ( !$restart ) { + while ( accept( Remote, $daemon ) ) { + DEBUG && warn "New connection\n"; - my $disposition = $part->header('Content-Disposition'); - my %parameters = @{ ( split_header_words($disposition) )[0] }; + select Remote; - if ( $parameters{filename} ) { + Remote->blocking(1); - my $fh = IO::File->new_tmpfile; - $fh->write( $part->content ) or die $!; - $fh->seek( SEEK_SET, 0 ) or die $!; + # Read until we see all headers + $self->{inputbuf} = ''; - $c->req->uploads->{ $parameters{filename} } = { - fh => $fh, - size => ( stat $fh )[7], - type => $part->content_type - }; + if ( !$self->_read_headers ) { + # Error reading, give up + close Remote; + next LISTEN; + } - push( @params, $parameters{filename}, $fh ); + my ( $method, $uri, $protocol ) = $self->_parse_request_line; + + DEBUG && warn "Parsed request: $method $uri $protocol\n"; + next unless $method; + + unless ( uc($method) eq 'RESTART' ) { + + # Fork + if ( $options->{fork} ) { + if ( $pid = fork ) { + DEBUG && warn "Forked child $pid\n"; + next; + } + } + + $self->_handler( $class, $port, $method, $uri, $protocol ); + + if ( my $error = delete $self->{_write_error} ) { + close Remote; + + if ( !defined $pid ) { + next LISTEN; + } + } + + if ( defined $pid ) { + # Child process, close connection and exit + DEBUG && warn "Child process exiting\n"; + $daemon->close; + exit; + } } else { - push( @params, $parameters{name}, $part->content ); + 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; + } } } + continue { + close Remote; + } + } + + $daemon->close; + + DEBUG && warn "Shutting down\n"; + + 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, @{ $options->{argv} }; } - my $parameters = $c->req->parameters; + exit; +} + +sub _handler { + my ( $self, $class, $port, $method, $uri, $protocol ) = @_; + + 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 ); + + REQUEST: + 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, + ); - while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) { + # Parse headers + if ( $protocol >= 1 ) { + $self->_parse_headers; + } - if ( exists $parameters->{$name} ) { - for ( $parameters->{$name} ) { - $_ = [$_] unless ref($_) eq "ARRAY"; - push( @$_, $value ); + # Pass flow control to Catalyst + $class->handle_request; + + DEBUG && warn "Request done\n"; + + # Allow keepalive requests, this is a hack but we'll support it until + # the next major release. + if ( delete $self->{_keepalive} ) { + + DEBUG && warn "Reusing previous connection for keep-alive request\n"; + + if ( $sel->can_read(1) ) { + if ( !$self->_read_headers ) { + # Error reading, give up + last REQUEST; + } + + ( $method, $uri, $protocol ) = $self->_parse_request_line; + + DEBUG && warn "Parsed request: $method $uri $protocol\n"; + + # Force HTTP/1.0 + $protocol = '1.0'; + + next REQUEST; } + + DEBUG && warn "No keep-alive request within 1 second\n"; } - else { - $parameters->{$name} = $value; - } + + last REQUEST; } + + DEBUG && warn "Closing connection\n"; + + close Remote; } -=item $c->prepare_path +sub _read_headers { + my $self = shift; -=cut + while (1) { + my $read = sysread Remote, my $buf, CHUNKSIZE; -sub prepare_path { - my $c = shift; + if ( !defined $read ) { + next if $! == EWOULDBLOCK; + DEBUG && warn "Error reading headers: $!\n"; + return; + } elsif ( $read == 0 ) { + DEBUG && warn "EOF\n"; + return; + } - my $base; - { - my $scheme = $c->http->request->uri->scheme; - my $host = $c->http->request->uri->host; - my $port = $c->http->request->uri->port; + DEBUG && warn "Read $read bytes\n"; + $self->{inputbuf} .= $buf; + last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s; + } - $base = URI->new; - $base->scheme($scheme); - $base->host($host); - $base->port($port); + return 1; +} - $base = $base->canonical->as_string; +sub _parse_request_line { + my $self = shift; + + # Parse request line + if ( $self->{inputbuf} !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { + return (); } - my $path = $c->http->request->uri->path || '/'; - $path =~ s/^\///; + my $method = $1; + my $uri = $2; + my $proto = $3 || 'HTTP/0.9'; - $c->req->base($base); - $c->req->path($path); + return ( $method, $uri, $proto ); } -=item $c->prepare_request($r) - -=cut +sub _parse_headers { + my $self = shift; + + # Copy the buffer for header parsing, and remove the header block + # from the content buffer. + my $buf = $self->{inputbuf}; + $self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s; + + # Parse headers + my $headers = HTTP::Headers->new; + my ($key, $val); + HEADER: + while ( $buf =~ s/^([^\012]*)\012// ) { + $_ = $1; + s/\015$//; + if ( /^([\w\-~]+)\s*:\s*(.*)/ ) { + $headers->push_header( $key, $val ) if $key; + ($key, $val) = ($1, $2); + } + elsif ( /^\s+(.*)/ ) { + $val .= " $1"; + } + else { + last HEADER; + } + } + $headers->push_header( $key, $val ) if $key; + + DEBUG && warn "Parsed headers: " . dump($headers) . "\n"; + + # Convert headers into ENV vars + $headers->scan( sub { + my ( $key, $val ) = @_; + + $key = uc $key; + $key = 'COOKIE' if $key eq 'COOKIES'; + $key =~ tr/-/_/; + $key = 'HTTP_' . $key + unless $key =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/; + + if ( exists $ENV{$key} ) { + $ENV{$key} .= ", $val"; + } + else { + $ENV{$key} = $val; + } + } ); +} -sub prepare_request { - my ( $c, $http ) = @_; - $c->http($http); +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; } -=item $c->prepare_uploads +sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } -=cut +no Moose; -sub prepare_uploads { - my $c = shift; -} +=head1 SEE ALSO -=back +L, L. -=head1 SEE ALSO +=head1 AUTHORS + +Sebastian Riedel, + +Dan Kubb, + +Sascha Kiefer, -L. +Andy Grundman, -=head1 AUTHOR +=head1 THANKS -Sebastian Riedel, C -Christian Hansen, C +Many parts are ripped out of C by Jesse Vincent. =head1 COPYRIGHT