[Catalyst-commits] r7040 - in trunk: . Catalyst-Engine-HTTP-Sprocket
Catalyst-Engine-HTTP-Sprocket/lib
Catalyst-Engine-HTTP-Sprocket/lib/Catalyst
Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine
Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP
Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket
Catalyst-Engine-HTTP-Sprocket/lib/POE
Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter
Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD
andyg at dev.catalyst.perl.org
andyg at dev.catalyst.perl.org
Mon Oct 22 07:14:52 GMT 2007
Author: andyg
Date: 2007-10-22 07:14:52 +0100 (Mon, 22 Oct 2007)
New Revision: 7040
Added:
trunk/Catalyst-Engine-HTTP-Sprocket/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket.pm
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm
trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm
trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD/
trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD/HeadersOnly.pm
Log:
Prelim work on a better POE engine, using Sprocket and child processes
Added: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm 2007-10-22 06:14:52 UTC (rev 7040)
@@ -0,0 +1,226 @@
+package Catalyst::Engine::HTTP::Sprocket::Server;
+
+# $Id$
+
+use strict;
+use base qw(Sprocket::Plugin);
+
+use Data::Dump qw(dump);
+use POE;
+use POE::Filter::HTTPD::HeadersOnly;
+use POE::Filter::Reference;
+use POE::Filter::Stream;
+use POE::Wheel::Run;
+
+use Catalyst::Engine::HTTP::Sprocket::Worker;
+
+sub DEBUG () { $ENV{CATALYST_POE_DEBUG} || 0 }
+
+sub OK() { 1 }
+
+sub new {
+ my ( $class, $config ) = @_;
+
+ # Number of children to fork
+ $config->{children} ||= 1;
+
+ my $self = $class->SUPER::new(
+ name => 'Catalyst Server',
+ config => $config,
+ );
+
+ POE::Session->create(
+ object_states => [
+ $self => [ qw(
+ _start
+
+ child_error
+ child_closed
+ child_stdout
+ child_stderr
+ sig_child
+ ) ],
+ ],
+ );
+
+ return $self;
+}
+
+sub _start {
+ my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
+
+ $kernel->alias_set( "$self" );
+
+ # Fork child proc(s)
+ $self->{children} = {};
+ $self->{child_busy} = {};
+
+ for ( 1 .. $self->{config}->{children} ) {
+ my $wheel = POE::Wheel::Run->new(
+ Program => \&Catalyst::Engine::HTTP::Sprocket::Worker::run,
+ ProgramArgs => [ $self->{config} ],
+ CloseOnCall => ($^O eq 'MSWin32' ? 0 : 1),
+ ErrorEvent => 'child_error',
+ CloseEvent => 'child_closed',
+ StdoutEvent => 'child_stdout',
+ StderrEvent => 'child_stderr',
+ StdinFilter => POE::Filter::Reference->new(),
+ StdoutFilter => POE::Filter::Stream->new(),
+ StderrFilter => POE::Filter::Line->new(),
+ );
+
+ # Check for errors
+ if ( !defined $wheel ) {
+ die "Unable to create worker process";
+ }
+
+ # Setup CHLD handler
+ if ( $kernel->can('sig_child') ) {
+ $kernel->sig_child( $wheel->PID, 'sig_child' );
+ }
+ else {
+ $kernel->sig( CHLD => 'sig_child' );
+ }
+
+ $self->{children}->{ $wheel->ID } = $wheel;
+
+ # Set child's status to inactive
+ $self->{child_busy}->{ $wheel->ID } = 0;
+ }
+
+ return $self;
+}
+
+### Sprocket server methods
+
+sub local_connected {
+ my ( $self, $server, $con, $socket ) = @_;
+
+ $self->take_connection( $con );
+
+ $con->filter->push(
+ POE::Filter::HTTPD::HeadersOnly->new(
+ headers_only => 1,
+ )
+ );
+
+ #$con->set_time_out( 5 );
+
+ return OK;
+}
+
+sub local_receive {
+ my ( $self, $server, $con, $req ) = @_;
+
+ # XXX: Static requests should be handled directly with AIO
+
+ # If this connection is now handling body data, just pass it along
+ if ( my $id = $con->{_body_mode} ) {
+ DEBUG && warn "[$id] Passed along " . length($req) . " bytes of body data\n";
+ $self->{children}->{ $id }->put( $req );
+ return 1;
+ }
+
+ warn "local_receive: " . dump($req) . "\n";
+
+ # Find a free child to send the request to
+ for my $id ( keys %{ $self->{children} } ) {
+ next if $self->{child_busy}->{ $id };
+
+ # Mark the child as busy handling this connection
+ $self->{child_busy}->{ $id } = $con;
+
+ # Add connection info to request
+ $req->{_con_addr} = $con->peer_ip;
+ $req->{_con_host} = $con->peer_hostname;
+ $req->{_con_server} = $con->local_ip;
+ $req->{_con_sport} = $con->local_port;
+
+ DEBUG && warn "[$id] " . $req->method . ' ' . $req->uri . "\n";
+
+ # Send the request
+ $self->{children}->{ $id }->put( $req );
+
+ # Change the filter to Stream if this is not a GET/HEAD request
+ if ( $req->method !~ /^(?:GET|HEAD)$/ ) {
+ DEBUG && warn "[$id] Switched to Stream filter for " . $req->method . " body\n";
+
+ $self->{children}->{ $id }->set_stdin_filter( POE::Filter::Stream->new() );
+
+ $con->{_body_mode} = $id;
+ # Existing body data in the filter's buffer will be ready immediately,
+ # additional data will come in through this method, we will detect this with
+ # the _body_mode flag
+ }
+
+ # Get pending data out of the HeadersOnly filter and pass it along
+ my $pending = $con->filter->get_pending();
+ if ( @{$pending} ) {
+ DEBUG && warn "[$id] Passed along " . length( $pending->[0] ) . " bytes of body data\n";
+ $self->{children}->{ $id }->put( $pending->[0] );
+ }
+
+ # Pop the HeadersOnly filter off, we use Stream for the response
+ $con->filter->pop();
+
+ return OK;
+ }
+
+ # XXX: no child available to handle the request
+ return;
+}
+
+### Child handlers
+
+sub child_error {
+ my ( $kernel, $self, $op, $errnum, $errstr, $wheel_id ) = @_[ KERNEL, OBJECT, ARG0 .. ARG3 ];
+
+ $errstr = "remote end closed" if $op eq "read" and !$errnum;
+
+ warn "Child $wheel_id generated $op error $errnum: $errstr\n";
+
+ delete $self->{children}->{ $wheel_id };
+ delete $self->{child_busy}->{ $wheel_id };
+
+ # XXX: start another child
+}
+
+sub child_closed {
+ my ( $kernel, $self, $wheel_id ) = @_[ KERNEL, OBJECT, ARG0 ];
+
+ DEBUG && warn "Child closed: $wheel_id\n";
+
+ delete $self->{children}->{ $wheel_id };
+ delete $self->{child_busy}->{ $wheel_id };
+
+ # XXX: start another child
+}
+
+sub child_stdout {
+ my ( $kernel, $self, $input, $wheel_id ) = @_[ KERNEL, OBJECT, ARG0, ARG1 ];
+
+ #DEBUG && warn "Child $wheel_id stdout: $input\n";
+
+ my $con = $self->{child_busy}->{ $wheel_id };
+
+ $con->send( $input );
+
+ # XXX: how best to detect the response has completed so we can
+ # mark the child as free to handle another request
+}
+
+sub child_stderr {
+ my ( $kernel, $self, $input, $wheel_id ) = @_[ KERNEL, OBJECT, ARG0, ARG1 ];
+
+ DEBUG && warn "[$wheel_id] $input\n";
+}
+
+sub sig_child {
+ my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
+
+ # XXX: remove child from children hash
+
+ $kernel->sig_handled();
+}
+
+1;
\ No newline at end of file
Property changes on: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Server.pm
___________________________________________________________________
Name: svn:keywords
+ Id
Added: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm 2007-10-22 06:14:52 UTC (rev 7040)
@@ -0,0 +1,144 @@
+package Catalyst::Engine::HTTP::Sprocket::Worker;
+
+# $Id$
+
+use strict;
+use base qw(Catalyst::Engine::CGI);
+
+use Data::Dump qw(dump);
+use HTTP::Status qw(status_message);
+use NEXT;
+use POE::Filter::Reference;
+
+sub new {
+ my ( $class, $config ) = @_;
+
+ bless {
+ config => $config,
+ body => '',
+ }, $class;
+}
+
+sub run {
+ my $config = shift;
+
+ if ( $^O eq 'MSWin32' ) {
+ binmode STDIN;
+ binmode STDOUT;
+ }
+
+ # Autoflush to avoid weirdness
+ select(STDOUT); $|++;
+ select(STDERR); $|++;
+
+ $SIG{__WARN__} = 'DEFAULT';
+ $SIG{__DIE__} = 'DEFAULT';
+
+ my $filter = POE::Filter::Reference->new();
+
+ # Change the Catalyst Engine class to us
+ my $self = __PACKAGE__->new( $config );
+
+ $config->{appclass}->engine( $self );
+
+ my %copy_of_env = %ENV;
+
+ while ( sysread STDIN, my $buf = '', 1024 ) {
+ my $req = $filter->get( [ $buf ] );
+
+ if ( @{$req} ) {
+ $req = $req->[0];
+
+ my ( $path, $query_string ) = split /\?/, $req->uri, 2;
+
+ # Initialize CGI environment
+ local %ENV = (
+ PATH_INFO => $path || '',
+ QUERY_STRING => $query_string || '',
+ REMOTE_ADDR => $req->{_con_addr},
+ REMOTE_HOST => $req->{_con_host},
+ REQUEST_METHOD => $req->method || '',
+ SERVER_NAME => $req->{_con_server},
+ SERVER_PORT => $req->{_con_sport},
+ SERVER_PROTOCOL => $req->protocol,
+ %copy_of_env,
+ );
+
+ # Convert headers into ENV vars
+ $req->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;
+ }
+ } );
+
+ # Pull out any pending data from the filter for use by read_chunk
+ my $pending = $filter->get_pending();
+ if ( @{$pending} ) {
+ $self->{body} = $pending->[0];
+ }
+
+ # Pass flow to Catalyst
+ $config->{appclass}->handle_request();
+ }
+ }
+}
+
+sub finalize_headers {
+ my ( $self, $c ) = @_;
+
+ my $protocol = $c->request->protocol;
+ my $status = $c->response->status;
+ my $message = status_message($status);
+
+ *STDOUT->syswrite( "$protocol $status $message\015\012" );
+
+ $self->NEXT::finalize_headers($c);
+}
+
+sub read_chunk {
+ my ( $self, $c ) = ( shift, shift );
+
+ # If we have existing body data, deal with that first
+ my $existing_len;
+
+ if ( $self->{body} ) {
+ $_[0] = delete $self->{body};
+ $existing_len = length( $_[0] );
+
+ #warn "read_chunk: got $existing_len bytes of existing data\n";
+
+ if ( $_[1] <= $existing_len ) {
+ #warn "caller only wanted $_[1] bytes, returning\n";
+ # full body was contained in existing data
+ substr $_[0], 0, $_[1];
+ return length( $_[0] );
+ }
+ else {
+ $_[1] -= $existing_len;
+ }
+ }
+
+ # We have more to read
+ #warn "Reading $_[1] more from STDIN\n";
+ my $rc = sysread STDIN, my $buf = '', $_[1];
+ if ( defined $rc ) {
+ #warn "OK, read $rc bytes\n";
+ $_[0] .= $buf;
+ return $rc + $existing_len;
+ }
+
+ return;
+}
+
+1;
\ No newline at end of file
Property changes on: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket/Worker.pm
___________________________________________________________________
Name: svn:keywords
+ Id
Added: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket.pm (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket.pm 2007-10-22 06:14:52 UTC (rev 7040)
@@ -0,0 +1,60 @@
+package Catalyst::Engine::HTTP::Sprocket;
+
+# $Id$
+
+use strict;
+
+use Sprocket qw(Server);
+use POE;
+use Socket;
+
+use Catalyst::Engine::HTTP::Sprocket::Server;
+
+our $VERSION = '0.01';
+
+sub DEBUG () { $ENV{CATALYST_POE_DEBUG} || 0 }
+
+sub new {
+ my $class = shift;
+
+ bless {}, $class;
+}
+
+sub run {
+ my ( $self, $class, $port, $host, $options ) = @_;
+
+ 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);
+ }
+
+ my $config = {
+ appclass => $class,
+ addr => $addr,
+ port => $port,
+ host => $host,
+ options => $options,
+ };
+
+ Sprocket::Server->spawn(
+ LogLevel => ( DEBUG ? 4 : 1 ),
+ Name => 'Catalyst',
+ ListenPort => $port,
+ ListenAddress => $addr,
+ Plugins => [
+ {
+ Plugin => Catalyst::Engine::HTTP::Sprocket::Server->new(
+ $config,
+ ),
+ },
+ ],
+ );
+
+ POE::Kernel->run;
+}
+
+1;
\ No newline at end of file
Property changes on: trunk/Catalyst-Engine-HTTP-Sprocket/lib/Catalyst/Engine/HTTP/Sprocket.pm
___________________________________________________________________
Name: svn:keywords
+ Id
Added: trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD/HeadersOnly.pm
===================================================================
--- trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD/HeadersOnly.pm (rev 0)
+++ trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD/HeadersOnly.pm 2007-10-22 06:14:52 UTC (rev 7040)
@@ -0,0 +1,495 @@
+# $Id$
+
+# Filter::HTTPD Copyright 1998 Artur Bergman <artur at vogon.se>.
+
+# Thanks go to Gisle Aas for his excellent HTTP::Daemon. Some of the
+# get code was copied out if, unfortunately HTTP::Daemon is not easily
+# subclassed for POE because of the blocking nature.
+
+# 2001-07-27 RCC: This filter will not support the newer get_one()
+# interface. It gets single things by default, and it does not
+# support filter switching. If someone absolutely needs to switch to
+# and from HTTPD filters, they should submit their request as a patch.
+
+package POE::Filter::HTTPD::HeadersOnly;
+
+use strict;
+use POE::Filter;
+
+use vars qw($VERSION @ISA);
+$VERSION = do {my($r)=(q$Revision: 2155 $=~/(\d+)/);sprintf"1.%04d",$r};
+ at ISA = qw(POE::Filter);
+
+sub BUFFER () { 0 }
+sub TYPE () { 1 }
+sub FINISH () { 2 }
+sub HEADER () { 3 }
+sub CLIENT_PROTO () { 4 }
+sub HEADER_ONLY () { 5 }
+
+use Carp qw(croak);
+use HTTP::Status qw( status_message RC_BAD_REQUEST RC_OK RC_LENGTH_REQUIRED );
+use HTTP::Request ();
+use HTTP::Response ();
+use HTTP::Date qw(time2str);
+use URI ();
+
+my $HTTP_1_0 = _http_version("HTTP/1.0");
+my $HTTP_1_1 = _http_version("HTTP/1.1");
+
+#------------------------------------------------------------------------------
+
+sub new {
+ my $type = shift;
+ my %opts = @_;
+ my $self = [
+ '', # BUFFER
+ 0, # TYPE
+ 0, # FINISH
+ undef, # HEADER
+ undef, # CLIENT_PROTO
+ ( $opts{headers_only} ? 1 : 0 ),
+ ];
+ bless $self, $type;
+ $self;
+}
+
+#------------------------------------------------------------------------------
+
+sub get_one_start {
+ my ($self, $stream) = @_;
+# return if ( $self->[FINISH] ); # XXX check this for correctness!
+ $stream = [ $stream ] unless ( ref( $stream ) );
+ $self->[BUFFER] .= join( '', @$stream );
+}
+
+sub get_one {
+ my ($self) = @_;
+ return ( $self->[FINISH] ) ? [] : $self->get( [] );
+}
+
+sub get {
+ my ($self, $stream) = @_;
+
+ # Need to check lengths in octets, not characters.
+ use bytes;
+
+ # Why?
+ local($_);
+
+ # Sanity check. "finish" is set when a request has completely
+ # arrived. Subsequent get() calls on the same request should not
+ # happen. -><- Maybe this should return [] instead of dying?
+
+ if ($self->[FINISH]) {
+
+ # This works around a request length vs. actual content length
+ # error. Looks like some browsers (mozilla!) sometimes add on an
+ # extra newline?
+
+ # return [] unless @$stream and grep /\S/, @$stream;
+
+ my @dump;
+ my $offset = 0;
+ $stream = $self->[BUFFER].join("", @$stream);
+ while (length $stream) {
+ my $line = substr($stream, 0, 16);
+ substr($stream, 0, 16) = '';
+
+ my $hexdump = unpack 'H*', $line;
+ $hexdump =~ s/(..)/$1 /g;
+
+ $line =~ tr[ -~][.]c;
+ push @dump, sprintf( "%04x %-47.47s - %s\n", $offset, $hexdump, $line );
+ $offset += 16;
+ }
+
+ return [
+ $self->_build_error(
+ RC_BAD_REQUEST,
+ "Did not want any more data. Got this:" .
+ "<p><pre>" . join("", @dump) . "</pre></p>"
+ )
+ ];
+ }
+
+ # Accumulate data in a framing buffer.
+
+ $self->[BUFFER] .= join('', @$stream);
+
+ # If headers were already received, then the framing buffer is
+ # purely content. Return nothing until content-length bytes are in
+ # the buffer, then return the entire request.
+
+ if ($self->[HEADER]) {
+ my $buf = $self->[BUFFER];
+ my $r = $self->[HEADER];
+ my $cl = $r->content_length() || length($buf) || 0;
+
+ # Some browsers (like MSIE 5.01) send extra CRLFs after the
+ # content. Shame on them. Now we need a special case to drop
+ # their extra crap.
+ #
+ # We use the first $cl octets of the buffer as the request
+ # content. It's then stripped away. Leading whitespace in
+ # whatever is left is also stripped away. Any nonspace data left
+ # over will throw an error.
+ #
+ # Four-argument substr() would be ideal here, but it's a
+ # relatively recent development.
+ #
+ # PG- CGI.pm only reads Content-Length: bytes from STDIN.
+ if (length($buf) >= $cl) {
+ $r->content(substr($buf, 0, $cl));
+ $self->[BUFFER] = substr($buf, $cl);
+ $self->[BUFFER] =~ s/^\s+//;
+
+ # We are sending this back, so won't need it anymore.
+ $self->[HEADER] = undef;
+ $self->[FINISH]++;
+ return [$r];
+ }
+
+ #print "$cl wanted, got " . length($buf) . "\n";
+ return [];
+ }
+
+ # Headers aren't already received. Short-circuit header parsing:
+ # don't return anything until we've received a blank line.
+
+ return [] unless(
+ $self->[BUFFER] =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s
+ );
+
+ # Copy the buffer for header parsing, and remove the header block
+ # from the content buffer.
+
+ my $buf = $self->[BUFFER];
+ $self->[BUFFER] =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s;
+
+ # Parse the request line.
+ if ($buf !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
+ return [
+ $self->_build_error(RC_BAD_REQUEST, "Request line parse failure.")
+ ];
+ }
+ my $proto = $3 || "HTTP/0.9";
+
+ # Use the request line to create a request object.
+
+ my $r = HTTP::Request->new($1, URI->new($2));
+ $r->protocol($proto);
+ $self->[CLIENT_PROTO] = $proto = _http_version($proto);
+
+ # Add the raw request's headers to the request object we'll be
+ # returning.
+
+ if ($proto >= $HTTP_1_0) {
+ my ($key,$val);
+ HEADER: while ($buf =~ s/^([^\012]*)\012//) {
+ $_ = $1;
+ s/\015$//;
+ if (/^([\w\-~]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ else {
+ last HEADER;
+ }
+ }
+ $r->push_header($key,$val) if($key);
+ }
+
+ $self->[HEADER] = $r;
+
+ # If this is a GET or HEAD request, we won't be expecting a message
+ # body. Finish up.
+
+ my $method = $r->method();
+ if ($method eq 'GET' or $method eq 'HEAD') {
+ $self->[FINISH]++;
+ # We are sending this back, so won't need it anymore.
+ $self->[HEADER] = undef;
+ return [$r];
+ }
+
+ # However, if it's any other type of request, check whether the
+ # entire content has already been received! If so, add that to the
+ # request and we're done. Otherwise we'll expect a subsequent get()
+ # call to finish things up.
+
+ #print "post:$buf:\END BUFFER\n";
+ #print length($buf)."-".$r->content_length()."\n";
+
+ if ($self->[HEADER_ONLY]) {
+ $self->[FINISH]++;
+ $self->[HEADER] = undef;
+ return [$r];
+ }
+
+ my $cl = $r->content_length();
+ unless(defined $cl) {
+ if($self->[CLIENT_PROTO] == 9) {
+ return [
+ $self->_build_error(
+ RC_BAD_REQUEST,
+ "POST request detected in an HTTP 0.9 transaction. " .
+ "POST is not a valid HTTP 0.9 transaction type. " .
+ "Please verify your HTTP version and transaction content."
+ )
+ ];
+ }
+ elsif ($method eq 'OPTIONS' || $method eq 'CONNECT') {
+ $self->[FINISH]++;
+ # OPTIONS requests can have an optional content length
+ # See http://www.faqs.org/rfcs/rfc2616.html, section 9.2
+ $self->[HEADER] = undef;
+ return [$r];
+ }
+ else {
+ return [
+ $self->_build_error(RC_LENGTH_REQUIRED, "No content length found.")
+ ];
+ }
+ }
+
+ unless ($cl =~ /^\d+$/) {
+ return [
+ $self->_build_error(
+ RC_BAD_REQUEST,
+ "Content length contains non-digits."
+ )
+ ];
+ }
+
+ if (length($buf) >= $cl) {
+ $r->content(substr($buf, 0, $cl));
+ $self->[BUFFER] = substr($buf, $cl);
+ $self->[BUFFER] =~ s/^\s+//;
+ $self->[FINISH]++;
+ # We are sending this back, so won't need it anymore.
+ $self->[HEADER] = undef;
+ return [$r];
+ }
+
+ return [];
+}
+
+#------------------------------------------------------------------------------
+
+sub put {
+ my ($self, $responses) = @_;
+ my @raw;
+
+ # HTTP::Response's as_string method returns the header lines
+ # terminated by "\n", which does not do the right thing if we want
+ # to send it to a client. Here I've stolen HTTP::Response's
+ # as_string's code and altered it to use network newlines so picky
+ # browsers like lynx get what they expect.
+
+ foreach (@$responses) {
+ # XXX stream the non response data?
+ next unless ( ref( $_ ) );
+
+ my $code = $_->code;
+ my $status_message = status_message($code) || "Unknown Error";
+ my $message = $_->message || "";
+ my $proto = $_->protocol || 'HTTP/1.0';
+
+ my $status_line = "$proto $code";
+ $status_line .= " ($status_message)" if $status_message ne $message;
+ $status_line .= " $message" if length($message);
+
+ # Use network newlines, and be sure not to mangle newlines in the
+ # response's content.
+
+ my @headers;
+ push @headers, $status_line;
+ push @headers, $_->headers_as_string("\x0D\x0A");
+
+ push @raw, join("\x0D\x0A", @headers, "") . $_->content;
+ }
+
+ # Allow next request after we're done sending the response.
+ $self->[FINISH]--;
+
+ \@raw;
+}
+
+#------------------------------------------------------------------------------
+
+sub get_pending {
+ my $self = shift;
+ # XXX does this do the right thing?
+ return [ $self->[BUFFER] ];
+}
+
+#------------------------------------------------------------------------------
+# Functions specific to HTTPD;
+#------------------------------------------------------------------------------
+
+# Internal function to parse an HTTP status line and return the HTTP
+# protocol version.
+
+sub _http_version {
+ local($_) = shift;
+ return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
+ $1 * 1000 + $2;
+}
+
+# Build a basic response, given a status, a content type, and some
+# content.
+
+sub _build_basic_response {
+ my ($self, $content, $content_type, $status) = @_;
+
+ # Need to check lengths in octets, not characters.
+ use bytes;
+
+ $content_type ||= 'text/html';
+ $status ||= RC_OK;
+
+ my $response = HTTP::Response->new($status);
+
+ $response->push_header( 'Content-Type', $content_type );
+ $response->push_header( 'Content-Length', length($content) );
+ $response->content($content);
+
+ return $response;
+}
+
+sub _build_error {
+ my($self, $status, $details) = @_;
+
+ $status ||= RC_BAD_REQUEST;
+ $details ||= '';
+ my $message = status_message($status) || "Unknown Error";
+
+ return $self->_build_basic_response(
+ ( "<html>" .
+ "<head>" .
+ "<title>Error $status: $message</title>" .
+ "</head>" .
+ "<body>" .
+ "<h1>Error $status: $message</h1>" .
+ "<p>$details</p>" .
+ "</body>" .
+ "</html>"
+ ),
+ "text/html",
+ $status
+ );
+}
+
+###############################################################################
+1;
+
+__END__
+
+=head1 NAME
+
+POE::Filter::HTTPD - convert stream to HTTP::Request; HTTP::Response to stream
+
+=head1 SYNOPSIS
+
+ $httpd = POE::Filter::HTTPD->new();
+ $arrayref_with_http_response_as_string =
+ $httpd->put($full_http_response_object);
+ $arrayref_with_http_request_object =
+ $line->get($arrayref_of_raw_data_chunks_from_driver);
+
+=head1 DESCRIPTION
+
+The HTTPD filter parses the first HTTP 1.0 request from an incoming
+stream into an HTTP::Request object (if the request is good) or an
+HTTP::Response object (if the request was malformed). To send a
+response, give its put() method a HTTP::Response object.
+
+Here is a sample input handler:
+
+ sub got_request {
+ my ($heap, $request) = @_[HEAP, ARG0];
+
+ # The Filter::HTTPD generated a response instead of a request.
+ # There must have been some kind of error. You could also check
+ # (ref($request) eq 'HTTP::Response').
+ if ($request->isa('HTTP::Response')) {
+ $heap->{wheel}->put($request);
+ return;
+ }
+
+ # Process the request here.
+ my $response = HTTP::Response->new(200);
+ $response->push_header( 'Content-Type', 'text/html' );
+ $response->content( $request->as_string() );
+
+ $heap->{wheel}->put($response);
+ }
+
+Please see the documentation for HTTP::Request and HTTP::Response.
+
+=head1 PUBLIC FILTER METHODS
+
+Please see POE::Filter.
+
+=head1 CAVEATS
+
+It is possible to generate invalid HTTP using libwww. This is specifically a
+problem if you are talking to a Filter::HTTPD driven daemon using libwww. For
+example, the following code (taken almost verbatim from the
+HTTP::Request::Common documentation) will cause an error in a Filter::HTTPD
+daemon:
+
+ use HTTP::Request::Common;
+ use LWP::UserAgent;
+
+ my $ua = LWP::UserAgent->new();
+ $ua->request(POST 'http://some/poe/driven/site', [ foo => 'bar' ]);
+
+By default, HTTP::Request is HTTP version agnostic. It makes no attempt to add
+an HTTP version header unless you specifically declare a protocol using
+C<< $request->protocol('HTTP/1.0') >>.
+
+According to the HTTP 1.0 RFC (1945), when faced with no HTTP version header,
+the parser is to default to HTTP/0.9. Filter::HTTPD follows this convention. In
+the transaction detailed above, the Filter::HTTPD based daemon will return a 400
+error since POST is not a valid HTTP/0.9 request type.
+
+=head1 Streaming Media
+
+It is perfectly possible to use Filter::HTTPD for streaming output
+media. Even if it's not possible to change the input filter from
+Filter::HTTPD, by setting the output_filter to Filter::Stream and
+omitting any content in the HTTP::Response object.
+
+ $wheel->put($response); # Without content, it sends just headers.
+ $wheel->set_output_filter(POE::Filter::Stream->new());
+ $wheel->put("Raw content.");
+
+=head1 SEE ALSO
+
+POE::Filter.
+
+The SEE ALSO section in L<POE> contains a table of contents covering
+the entire POE distribution.
+
+=head1 BUGS
+
+=over 4
+
+=item * Keep-alive is not supported.
+
+=item * The full http 1.0 spec is not supported, specifically DELETE, LINK, and UNLINK.
+
+=back
+
+=head1 AUTHORS & COPYRIGHTS
+
+The HTTPD filter was contributed by Artur Bergman.
+
+Please see L<POE> for more information about authors and contributors.
+
+=cut
Property changes on: trunk/Catalyst-Engine-HTTP-Sprocket/lib/POE/Filter/HTTPD/HeadersOnly.pm
___________________________________________________________________
Name: svn:keywords
+ Id
More information about the Catalyst-commits
mailing list