X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FHTTP.pm;h=37ed3a95d1e4eaf7863f1a494c4c22e278792adf;hb=2b01b53cf7f8b98568f13a99e18257f78d7fa858;hp=861ec5a187e02a9258567ff712b8252f411330f8;hpb=66d9e175a28989d4454714edf2cc2dab5ad64d96;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 861ec5a..37ed3a9 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -1,24 +1,11 @@ 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 base 'Catalyst::Engine::CGI'; +use Errno 'EWOULDBLOCK'; +use HTTP::Status; +use NEXT; +use Socket; =head1 NAME @@ -26,202 +13,270 @@ 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 + + BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' } + + use strict; + use lib '/path/to/MyApp/lib'; + use MyApp; + + MyApp->run; -This Catalyst engine is meant to be subclassed. +=head1 DESCRIPTION -=head1 OVERLOADED METHODS +This is the Catalyst engine specialized for development and testing. -This class overloads some methods from C. +=head1 METHODS =over 4 -=item $c->finalize_headers +=item $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 ); - } - - $c->http->response($response); + 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); + $self->NEXT::finalize_headers($c); } -=item $c->finalize_output +=item $self->finalize_read($c) =cut -sub finalize_output { - my $c = shift; - $c->http->response->content_ref( \$c->response->{output} ); -} - -=item $c->prepare_connection +sub finalize_read { + my ( $self, $c ) = @_; -=cut + # Never ever remove this, it would result in random length output + # streams if STDIN eq STDOUT (like in the HTTP engine) + *STDIN->blocking(1); -sub prepare_connection { - my $c = shift; - $c->req->hostname( $c->http->hostname ); - $c->req->address( $c->http->address ); + return $self->NEXT::finalize_read($c); } -=item $c->prepare_cookies +=item $self->prepare_read($c) =cut -sub prepare_cookies { - my $c = shift; - - if ( my $header = $c->http->request->header('Cookie') ) { - $c->req->cookies( { CGI::Simple::Cookie->parse($header) } ); - } -} +sub prepare_read { + my ( $self, $c ) = @_; -=item $c->prepare_headers + # Set the input handle to non-blocking + *STDIN->blocking(0); -=cut - -sub prepare_headers { - my $c = shift; - $c->req->method( $c->http->request->method ); - $c->req->headers( $c->http->request->headers ); + return $self->NEXT::prepare_read($c); } -=item $c->prepare_parameters +=item $self->read_chunk($c, $buffer, $length) =cut -sub prepare_parameters { - my $c = shift; - - my @params = (); - my $request = $c->http->request; +sub read_chunk { + my $self = shift; + my $c = shift; - push( @params, $request->uri->query_form ); + # support for non-blocking IO + my $rin = ''; + vec( $rin, *STDIN->fileno, 1 ) = 1; - if ( $request->content_type eq 'application/x-www-form-urlencoded' ) { - my $uri = URI->new('http:'); - $uri->query( $request->content ); - push( @params, $uri->query_form ); + READ: + { + select( $rin, undef, undef, undef ); + my $rc = *STDIN->sysread(@_); + if ( defined $rc ) { + return $rc; + } + else { + next READ if $! == EWOULDBLOCK; + return; + } } +} - if ( $request->content_type eq 'multipart/form-data' ) { +=item run - for my $part ( $request->parts ) { +=cut - my $disposition = $part->header('Content-Disposition'); - my %parameters = @{ ( split_header_words($disposition) )[0] }; +# A very very simple HTTP server that initializes a CGI environment +sub run { + my ( $self, $class, $port, $host, $options ) = @_; - if ( $parameters{filename} ) { + $options ||= {}; - my $fh = IO::File->new_tmpfile; - $fh->write( $part->content ) or die $!; - $fh->seek( SEEK_SET, 0 ) or die $!; + our $GOT_HUP; + local $GOT_HUP = 0; - $c->req->uploads->{ $parameters{filename} } = { - fh => $fh, - size => ( stat $fh )[7], - type => $part->content_type - }; + local $SIG{HUP} = sub { $GOT_HUP = 1; }; + local $SIG{CHLD} = 'IGNORE'; - push( @params, $parameters{filename}, $fh ); - } - else { - push( @params, $parameters{name}, $part->content ); - } - } - } + my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' }; - my $parameters = $c->req->parameters; + # Handle requests - while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) { + # Setup socket + $host = $host ? inet_aton($host) : INADDR_ANY; + socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') ) + || die "Couldn't assign TCP socket: $!"; + setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) ) + || die "Couldn't set TCP socket options: $!"; + bind( HTTPDaemon, sockaddr_in( $port, $host ) ) + || die "Couldn't bind socket to $port on $host: $!"; + listen( HTTPDaemon, SOMAXCONN ) + || die "Couldn't listen to socket on $port on $host: $!"; + my $url = 'http://'; + if ( $host eq INADDR_ANY ) { + require Sys::Hostname; + $url .= lc Sys::Hostname::hostname(); + } + else { + $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host); + } + $url .= ":$port"; + print "You can connect to your server at $url\n"; + my $pid = undef; + while ( accept( Remote, HTTPDaemon ) ) { + + # Fork + if ( $options->{fork} ) { next if $pid = fork } + + close HTTPDaemon if defined $pid; + + # Ignore broken pipes as an HTTP server should + local $SIG{PIPE} = sub { close Remote }; + local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} ); + + local *STDIN = \*Remote; + local *STDOUT = \*Remote; + select STDOUT; + + # Request data + my $remote_sockaddr = getpeername( \*Remote ); + my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr); + my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost"; + my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1"; + my $local_sockaddr = getsockname( \*Remote ); + my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr); + my $localname = gethostbyaddr( $localiaddr, AF_INET ) + || "localhost"; + my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1"; + + STDIN->blocking(1); + + # Parse request line + my $line = $self->_get_line( \*STDIN ); + next + unless my ( $method, $uri, $protocol ) = + $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/; + + # We better be careful and just use 1.0 + $protocol = '1.0'; + + my ( $path, $query_string ) = split /\?/, $uri, 2; + + # Initialize CGI environment + local %ENV = ( + PATH_INFO => $path || '', + QUERY_STRING => $query_string || '', + REMOTE_ADDR => $peeraddr, + REMOTE_HOST => $peername, + REQUEST_METHOD => $method || '', + SERVER_NAME => $localname, + SERVER_PORT => $port, + SERVER_PROTOCOL => "HTTP/$protocol", + %ENV, + ); - if ( exists $parameters->{$name} ) { - for ( $parameters->{$name} ) { - $_ = [$_] unless ref($_) eq "ARRAY"; - push( @$_, $value ); + # 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; + } } } + unless ( uc($method) eq 'KILL' ) { + + # Pass flow control to Catalyst + $class->handle_request; + } else { - $parameters->{$name} = $value; + my $ipaddr = _inet_addr($peeraddr); + my $ready = 0; + while ( my ( $ip, $mask ) = each %$allowed and not $ready ) { + $ready = ( $ipaddr & _inet_addr($mask) ) == _inet_addr($ip); + } + if ($ready) { + $GOT_HUP = 1; + last; + } } + exit if defined $pid; } -} - -=item $c->prepare_path - -=cut + continue { + close Remote; + } + close HTTPDaemon; -sub prepare_path { - my $c = shift; + if ($GOT_HUP) { + $SIG{CHLD} = 'DEFAULT'; + wait; + exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } ); + } +} - my $base; - { - my $scheme = $c->http->request->uri->scheme; - my $host = $c->http->request->uri->host; - my $port = $c->http->request->uri->port; +sub _get_line { + my ( $self, $handle ) = @_; - $base = URI->new; - $base->scheme($scheme); - $base->host($host); - $base->port($port); + my $line = ''; - $base = $base->canonical->as_string; + while ( sysread( $handle, my $byte, 1 ) ) { + last if $byte eq "\012"; # eol + $line .= $byte; } - my $path = $c->http->request->uri->path || '/'; - $path =~ s/^\///; + 1 while $line =~ s/\s\z//; - $c->req->base($base); - $c->req->path($path); + return $line; } -=item $c->prepare_request($r) - -=cut - -sub prepare_request { - my ( $c, $http ) = @_; - $c->http($http); -} +sub _inet_addr { unpack "N*", inet_aton( $_[0] ) } -=item $c->prepare_uploads +=back -=cut +=head1 SEE ALSO -sub prepare_uploads { - my $c = shift; -} +L, L. -=back +=head1 AUTHORS -=head1 SEE ALSO +Sebastian Riedel, -L. +Dan Kubb, -=head1 AUTHOR +=head1 THANKS -Sebastian Riedel, C -Christian Hansen, C +Many parts are ripped out of C by Jesse Vincent. =head1 COPYRIGHT