Changeset 13439

Timestamp:

06/08/08 06:23:24 (5 years ago)

Author:

nothingmuch

Message:

fix Standalone

Location:

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine

Files:

• Interface/Standalone (added)
• Interface/Standalone.pm (modified) (9 diffs)
• Interface/Standalone/RequestBuilder.pm (added)
• Request.pm (modified) (2 diffs)
• RequestBuilder.pm (modified) (10 diffs)
• RequestProcessor.pm (modified) (2 diffs)
• ResponseWriter.pm (modified) (1 diff)
• Role/Interface.pm (modified) (5 diffs)
• Role/RequestBuilder/ReadBody.pm (modified) (5 diffs)

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/Interface/Standalone.pm

@@ -3 +3 @@
 with 'HTTP::Engine::Role::Interface';
 
-use Errno 'EWOULDBLOCK';
 use Socket qw(:all);
 use IO::Socket::INET ();
@@ -46 +45 @@
 );
 
-
-use HTTP::Engine::ResponseWriter;
-HTTP::Engine::RequestBuilder->meta->add_method( _read_chunk  => sub {
-    shift;
-    # support for non-blocking IO
-    my $rin = '';
-    vec($rin, *STDIN->fileno, 1) = 1;
-
-    READ:
-    {
-        select($rin, undef, undef, undef); ## no critic.
-        my $rc = *STDIN->sysread(@_);
-        if (defined $rc) {
-           return $rc;
-       } else {
-            next READ if $! == EWOULDBLOCK;
-            return;
-        }
-    }
-});
-
-HTTP::Engine::RequestBuilder->meta->add_before_method_modifier( _prepare_read => sub {
-    my $self = shift;
-    # Set the input handle to non-blocking
-    *STDIN->blocking(0);
-});
-
-use HTTP::Engine::ResponseWriter;
-my $is_keepalive;
-HTTP::Engine::ResponseWriter->meta->add_before_method_modifier( finalize => sub {
-    my($self, $c) = @_;
-
-    $c->res->headers->date(time);
-    $c->res->headers->header(
-        Connection => $is_keepalive ? 'keep-alive' : 'close'
-    );
-});
-
 sub run {
-    my($self, ) = @_;
-
-    $is_keepalive = sub { $self->keepalive };
+    my ( $self ) = @_;
+
+    $self->response_writer->keepalive( $self->keepalive );
 
     my $host = $self->host;
@@ -119 +80 @@
     my $pid    = undef;
     local $SIG{CHLD} = 'IGNORE';
-    while (accept(Remote, $daemon)) {
+
+    while (my $remote = $daemon->accept) {
         # TODO (Catalyst): get while ( my $remote = $daemon->accept ) to work
         delete $self->{_sigpipe};
-        select Remote;
-
-        # Request data
-        Remote->blocking(1);
-
-        next unless my($method, $uri, $protocol) = $self->_parse_request_line(\*Remote);
+
+        next unless my($method, $uri, $protocol) = $self->_parse_request_line($remote);
         unless (uc $method eq 'RESTART') {
             # Fork
             next if $self->fork && ($pid = fork);
-            $self->_handler($port, $method, $uri, $protocol);
+            $self->_handler($remote, $port, $method, $uri, $protocol);
             $daemon->close if defined $pid;
         } else {
-            my $sockdata = $self->_socket_data(\*Remote);
+            my $sockdata = $self->_socket_data($remote);
             my $ipaddr   = _inet_addr($sockdata->{peeraddr});
             my $ready    = 0;
@@ -149 +107 @@
         exit if defined $pid;
     } continue {
-        close Remote;
+        close $remote;
     }
     $daemon->close;
@@ -163 +121 @@
 
 sub _handler {
-    my($self, $port, $method, $uri, $protocol) = @_;
+    my($self, $remote, $port, $method, $uri, $protocol) = @_;
 
     # Ignore broken pipes as an HTTP server should
-    local $SIG{PIPE} = sub { $self->{_sigpipe} = 1; close Remote };
-
-    local *STDIN  = \*Remote;
-    local *STDOUT = \*Remote;
+    local $SIG{PIPE} = sub { $self->{_sigpipe} = 1; close $remote };
 
     # We better be careful and just use 1.0
     $protocol = '1.0';
 
-    my $sockdata    = $self->_socket_data(\*Remote);
+    my $sockdata    = $self->_socket_data($remote);
     my %copy_of_env = %ENV;
 
     my $sel = IO::Select->new;
-    $sel->add(\*STDIN);
+    $sel->add($remote);
+
+    $remote->autoflush(1);
 
     while (1) {
+        # FIXME refactor an HTTP push parser
         my($path, $query_string) = split /\?/, $uri, 2;
 
-        # Initialize CGI environment
-        local %ENV = (
+        my %env = (
             PATH_INFO       => $path         || '',
             QUERY_STRING    => $query_string || '',
@@ -193 +150 @@
             SERVER_PORT     => $port,
             SERVER_PROTOCOL => "HTTP/$protocol",
-            %copy_of_env,
         );
 
+        my $headers;
+
         # Parse headers
+        # taken from HTTP::Message, which is unfortunately not really reusable
         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";
+            my @hdr;
+            while ( length(my $line = $self->_get_line($remote)) ) {
+                if ($line =~ s/^([^\s:]+)[ \t]*: ?(.*)//) {
+                    push(@hdr, $1, $2);
+                }
+                elsif (@hdr && $line =~ s/^([ \t].*)//) {
+                    $hdr[-1] .= "\n$1";
                 } else {
-                    $ENV{$name} = $value;
+                    last;
                 }
             }
+            $headers = HTTP::Headers->new(@hdr);
+        } else {
+            $headers = HTTP::Headers->new;
         }
+
         # Pass flow control to HTTP::Engine
-        $self->handle_request;
-
-        my $connection = lc $ENV{HTTP_CONNECTION};
+        $self->handle_request(
+            uri            => URI::WithBase->new($uri),
+            headers        => $headers,
+            method         => $method,
+            address        => $sockdata->{peeraddr},
+            port           => $port,
+            protocol       => "HTTP/$protocol",
+            user           => undef,
+            https_info     => undef,
+            _connection => {
+                handle => $remote,
+                env    => {},         # no more env than what we provide
+            },
+        );
+
+        my $connection = $headers->header("Connection");
+
         last
           unless $self->keepalive
@@ -224 +197 @@
           && $sel->can_read(5);
 
-        last unless ($method, $uri, $protocol) = $self->_parse_request_line(\*STDIN, 1);
-    }
-
-    sysread(Remote, my $buf, 4096) if $sel->can_read(0); # IE bk
-    close Remote;
+        last unless ($method, $uri, $protocol) = $self->_parse_request_line($remote, 1);
+    }
+
+    $self->request_builder->_io_read($remote, my $buf, 4096) if $sel->can_read(0); # IE bk
+    close $remote;
 }
 
@@ -254 +227 @@
 
     my $data = {
-        peername => gethostbyaddr($iaddr, AF_INET) || "localhost",
         peeraddr => inet_ntoa($iaddr) || "127.0.0.1",
-        localname => gethostbyaddr($localiaddr, AF_INET) || "localhost",
         localaddr => inet_ntoa($localiaddr) || "127.0.0.1",
     };
@@ -266 +237 @@
     my($self, $handle) = @_;
 
+    # FIXME use bufferred but nonblocking IO? this is a lot of calls =(
     my $line = '';
-    while (sysread($handle, my $byte, 1)) {
+    while ($self->request_builder->_io_read($handle, my $byte, 1)) {
         last if $byte eq "\012";    # eol
         $line .= $byte;
     }
-    1 while $line =~ s/\s\z//;
+
+    # strip \r, \n was already stripped
+    $line =~ s/\015$//s;
 
     $line;

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/Request.pm

@@ -17 +17 @@
     }
 }
+
+has _connection => (
+    is => "ro",
+    lazy_build => 1,
+);
+
+sub _build__request_state {
+    my $self = shift;
+    $self->request_builder->_build_request_state($self);
+}
+
+has "_read_state" => (
+    is => "rw",
+    lazy_build => 1,
+);
+
+sub _build__read_state {
+    my $self = shift;
+    $self->request_builder->_build_read_state($self);
+}
+
+
 has request_builder => (
     does => "HTTP::Engine::Role::RequestBuilder",
@@ -143 +165 @@
     my $self = shift;
     $self->request_builder->_build_hostname;
-}
-
-has "_read_state" => (
-    is => "rw",
-    lazy_build => 1,
-);
-
-sub _build__read_state {
-    my $self = shift;
-    $self->request_builder->_build_read_state($self);
 }
 

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/RequestBuilder.pm

@@ -19 +19 @@
 );
 
-has read_length => (
-    is  => 'rw',
-    isa => 'Int',
-);
-
-has read_position => (
-    is  => 'rw',
-    isa => 'Int',
-);
-
 no Moose;
+
+sub _build_connection {
+    warn "Building default request state";
+
+    return {
+        env    => \%ENV,
+        handle => \*STDIN,
+    }
+}
 
 sub _build_connection_info {
     my($self, $req) = @_;
 
+    warn "building connection info";
+
+    my $env = $self->_connection->{env};
+
     return {
-        address    => $ENV{REMOTE_ADDR},
-        protocol   => $ENV{SERVER_PROTOCOL},
-        method     => $ENV{REQUEST_METHOD},
-        port       => $ENV{SERVER_PORT},
-        user       => $ENV{REMOTE_USER},
-        https_info => $ENV{HTTPS},
+        address    => $env->{REMOTE_ADDR},
+        protocol   => $env->{SERVER_PROTOCOL},
+        method     => $env->{REQUEST_METHOD},
+        port       => $env->{SERVER_PORT},
+        user       => $env->{REMOTE_USER},
+        https_info => $env->{HTTPS},
     }
 }
@@ -46 +49 @@
 sub _build_headers {
     my ($self, $req) = @_;
+
+    my $env = $req->_connection->{env};
 
     HTTP::Headers->new(
         map {
             (my $field = $_) =~ s/^HTTPS?_//;
-            ( $field => $ENV{$_} );
+            ( $field => $env->{$_} );
         }
-        grep { /^(?:HTTP|CONTENT|COOKIE)/i } keys %ENV 
+        grep { /^(?:HTTP|CONTENT|COOKIE)/i } keys %$env
     );
 }
@@ -58 +63 @@
 sub _build_hostname {
     my ( $self, $req ) = @_;
-    $ENV{REMOTE_HOST} || $self->_resolve_hostname($req);
+    $req->_connection->{env}{REMOTE_HOST} || $self->_resolve_hostname($req);
 }
 
@@ -64 +69 @@
     my($self, $req) = @_;
 
+    my $env = $req->_connection->{env};
+
     my $scheme = $req->secure ? 'https' : 'http';
-    my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
-    my $port   = $ENV{SERVER_PORT} || ( $req->secure ? 443 : 80 );
+    my $host   = $env->{HTTP_HOST}   || $env->{SERVER_NAME};
+    my $port   = $env->{SERVER_PORT} || ( $req->secure ? 443 : 80 );
 
     my $base_path;
-    if (exists $ENV{REDIRECT_URL}) {
-        $base_path = $ENV{REDIRECT_URL};
-        $base_path =~ s/$ENV{PATH_INFO}$//;
+    if (exists $env->{REDIRECT_URL}) {
+        $base_path = $env->{REDIRECT_URL};
+        $base_path =~ s/$env->{PATH_INFO}$//;
     } else {
-        $base_path = $ENV{SCRIPT_NAME} || '/';
-    }
-
-    my $path = $base_path . ($ENV{PATH_INFO} || '');
+        $base_path = $env->{SCRIPT_NAME} || '/';
+    }
+
+    my $path = $base_path . ($env->{PATH_INFO} || '');
     $path =~ s{^/+}{};
 
@@ -84 +91 @@
     $uri->port($port);
     $uri->path($path);
-    $uri->query($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
+    $uri->query($env->{QUERY_STRING}) if $env->{QUERY_STRING};
 
     # sanitize the URI
@@ -101 +108 @@
     my($self, $req) = @_;
 
+    use Data::Dumper;
+    warn Dumper($req->headers);
+
     my $length = $req->header('Content-Length') || 0;
     my $type   = $req->header('Content-Type');
@@ -107 +117 @@
     $body->{tmpdir} = $self->upload_tmp if $self->upload_tmp;
 
-    return {
-        handle         => *STDIN,
+    return $self->_read_init({
+        handle         => $req->_connection->{handle},
         content_length => $length,
         read_position  => 0,
@@ -115 +125 @@
             http_body     => $body,
         },
-    };
+    });
 }
 
@@ -121 +131 @@
     my ( $self, $req ) = @_;
 
+    warn "constructing body";
     $self->_read_to_end($req->_read_state);
 
@@ -129 +140 @@
     my ( $self, $req ) = @_;
 
+    warn "constructing raw";
     $self->_read_to_end($req->_read_state);
 

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/RequestProcessor.pm

@@ -57 +57 @@
 my $rp;
 sub handle_request {
-    my $self = shift;
+    my ( $self, @args ) = @_;
 
     my $context = $self->context_class->new(
-        req    => $self->request_class->new( request_builder => $self->request_builder ),
-        res    => $self->response_class->new(),
+        req => $self->request_class->new(
+            request_builder => $self->request_builder,
+            @args,
+        ),
+        res => $self->response_class->new(@args),
+        @args,
     );
 
@@ -73 +77 @@
         print STDERR $e;
     }
+
     $self->response_writer->finalize($context);
 

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/ResponseWriter.pm

@@ -23 +23 @@
 sub finalize {
     my($self, $c) = @_;
+
+    local *STDOUT = $c->req->_connection->{handle};
     croak "argument missing" unless $c;
 

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/Role/Interface.pm

@@ -19 +19 @@
 
 sub request_processor_traits {
-    return;
+    my $self = shift;
+    $self->_default_trait("RequestProcessor");
 }
 
@@ -45 +46 @@
 
 sub request_builder_traits {
-    return;
+    my $self = shift;
+    $self->_default_trait("RequestBuilder");
 }
 
@@ -66 +68 @@
 
 sub response_writer_traits {
-    return;
+    my $self = shift;
+    $self->_default_trait("ResponseWriter");
 }
 
@@ -84 +87 @@
 
 
+sub _default_trait {
+    my ( $self, $category ) = @_;
 
+    my $name = join( "::", $self->meta->name, $category );
+
+    my $e;
+
+    # don't overwrite external $@
+    {
+        local $@;
+        if ( eval { Class::MOP::load_class($name) } ) {
+            return $name;
+        } else {
+            ( my $file = "$name.pm" ) =~ s{::}{/}g;
+            if ( $@ =~ /Can't locate \Q$file\E in \@INC/ ) {
+                return;
+            } else {
+                $e = $@;
+            }
+        }
+    }
+
+    die $e;
+}
 
 my %anon_classes;
@@ -117 +143 @@
     Moose::Util::apply_all_roles( $anon->name, @roles );
 
-    return $anon->name;
+    return $anon;
 }
 

lang/perl/HTTP-Engine/branches/lazy_request/lib/HTTP/Engine/Role/RequestBuilder/ReadBody.pm

@@ -7 +7 @@
 
 sub _read_init {
+    my ( $self, $read_state ) = @_;
+    warn "read init";
+    return $read_state;
+}
+
+sub _read_start {
     my ( $self, $state ) = @_;
-    $state->{initialized} = 1;
+    warn "read start";
+    $state->{started} = 1;
 }
 
@@ -15 +22 @@
 
     my $content_length = $state->{content_length};
+
+    warn "reading to end ($content_length)";
 
     if ($content_length > 0) {
@@ -30 +39 @@
         }
     }
+
+    warn "finished reading";
 }
 
@@ -42 +53 @@
 sub _read {
     my ($self, $state, $maxlength) = @_;
+
+    warn "reading";
     
-    $self->_read_init($state) unless $state->{initialized};
+    $self->_read_start($state) unless $state->{started};
 
     my ( $length, $pos ) = @{$state}{qw(content_length read_position)};
@@ -73 +86 @@
     my $handle = $state->{handle};
 
+    $self->_io_read( $handle, @_ );
+}
+
+sub _io_read {
+    my ( $self, $handle ) = ( shift, shift );
+
     if (blessed($handle)) {
-        return $handle->sysread(@_);
+        return $handle->read(@_);
     } else {
-        return sysread $handle, $_[0], $_[1], $_[2];
+        return read $handle, $_[0], $_[1], $_[2];
     }
 }