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=77bb79847273841c48d2a9008edf7ba0c19a5c41;hb=4090e3bb3fea1a73ac369250e31584d61428b808;hpb=7a1df40307d6825f3daac351c330fbd235cf9a47

diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm
index 77bb798..fb40d6f 100644
--- a/lib/Catalyst/Engine/HTTP.pm
+++ b/lib/Catalyst/Engine/HTTP.pm
@@ -1,14 +1,23 @@
 package Catalyst::Engine::HTTP;
 
-use strict;
-use base 'Catalyst::Engine::CGI';
+use Moose;
+extends 'Catalyst::Engine::CGI';
+
+use Data::Dump qw(dump);
 use Errno 'EWOULDBLOCK';
-use FindBin;
-use File::Find;
-use File::Spec;
+use HTTP::Date ();
+use HTTP::Headers;
 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;
+
+use constant CHUNKSIZE => 64 * 1024;
+use constant DEBUG     => $ENV{CATALYST_HTTP_DEBUG} || 0;
 
 =head1 NAME
 
@@ -34,9 +43,7 @@ This is the Catalyst engine specialized for development and testing.
 
 =head1 METHODS
 
-=over 4
-
-=item $self->finalize_headers($c)
+=head2 $self->finalize_headers($c)
 
 =cut
 
@@ -45,45 +52,69 @@ sub finalize_headers {
     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);
+    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");
+
+    # 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 $self->finalize_read($c)
+=head2 $self->finalize_read($c)
 
 =cut
 
-sub finalize_read {
-    my ( $self, $c ) = @_;
-
+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->(@_);
+};
 
-    return $self->NEXT::finalize_read($c);
-}
-
-=item $self->prepare_read($c)
+=head2 $self->prepare_read($c)
 
 =cut
 
-sub prepare_read {
-    my ( $self, $c ) = @_;
-
+around prepare_read => sub {
     # Set the input handle to non-blocking
     *STDIN->blocking(0);
+    shift->(@_);
+};
 
-    return $self->NEXT::prepare_read($c);
-}
-
-=item $self->read_chunk($c, $buffer, $length)
+=head2 $self->read_chunk($c, $buffer, $length)
 
 =cut
 
 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 = '';
@@ -94,6 +125,7 @@ sub read_chunk {
         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 {
@@ -103,7 +135,38 @@ sub read_chunk {
     }
 }
 
-=item run
+=head2 $self->write($c, $buffer)
+
+Writes the buffer to the client.
+
+=cut
+
+around write => sub {
+    my $orig = shift;
+    my ( $self, $c, $buffer ) = @_;
+
+    # Avoid 'print() on closed filehandle Remote' warnings when using IE
+    return unless *STDOUT->opened();
+
+    # 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
 
@@ -111,226 +174,358 @@ sub read_chunk {
 sub run {
     my ( $self, $class, $port, $host, $options ) = @_;
 
-    our $GOT_HUP;
-    local $GOT_HUP = 0;
+    $options ||= {};
+    
+    $self->{options} = $options;
 
-    local $SIG{HUP} = sub { $GOT_HUP = 1; };
-    local $SIG{CHLD} = 'IGNORE';
+    if ($options->{background}) {
+        my $child = fork;
+        die "Can't fork: $!" unless defined($child);
+        return $child if $child;
+    }
 
-    # Setup restarter
-    my $restarter;
-    if ( $options->{restart} ) {
-        my $parent = $$;
-        unless ( $restarter = fork ) {
-
-            # Prepare
-            close STDIN;
-            close STDOUT;
-
-            # Index parent directory
-            my $dir = File::Spec->catdir( $FindBin::Bin, '..' );
-
-            my $regex = $options->{restart_regex};
-            my $one   = _index( $dir, $regex );
-          RESTART: while (1) {
-                sleep $options->{restart_delay};
-                my $two     = _index( $dir,         $regex );
-                my $changes = _compare_index( $one, $two );
-                if (@$changes) {
-                    $one = $two;
-
-                    # Test modified pm's
-                    for my $file (@$changes) {
-                        next unless $file =~ /\.pm$/;
-                        if ( my $error = _test($file) ) {
-                            print STDERR
-                              qq/File "$file" modified, not restarting\n/;
-                            print STDERR '*' x 80, "\n";
-                            print STDERR $error;
-                            print STDERR '*' x 80, "\n";
-                            next RESTART;
-                        }
-                    }
+    my $restart = 0;
+    local $SIG{CHLD} = 'IGNORE';
 
-                    # Restart
-                    my $files = join ', ', @$changes;
-                    print STDERR qq/File(s) "$files" modified, restarting\n/;
-                    kill( 1, $parent );
-                    exit;
-                }
-            }
-        }
+    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
-    $host = $host ? inet_aton($host) : INADDR_ANY;
-    socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') );
-    setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) );
-    bind( HTTPDaemon, sockaddr_in( $port, $host ) );
-    listen( HTTPDaemon, SOMAXCONN );
-    my $url = 'http://';
-    if ( $host eq INADDR_ANY ) {
-        require Sys::Hostname;
-        $url .= lc Sys::Hostname::hostname();
+    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,  "+</dev/null" or die $!;
+        open STDOUT, ">&STDIN"     or die $!;
+        open STDERR, ">&STDIN"     or die $!;
+        if ( $^O !~ /MSWin32/ ) {
+             require POSIX;
+             POSIX::setsid()
+                 or die "Can't start a new session: $!";
+        }
     }
-    else {
-        $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host);
+
+    if (my $pidfile = $options->{pidfile}) {
+        if (! open PIDFILE, "> $pidfile") {
+            warn("Cannot open: $pidfile: $!");
+        }
+        print PIDFILE "$$\n";
+        close PIDFILE;
     }
-    $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 }
+    # 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";
+    };
 
-        close HTTPDaemon if defined $pid;
+    LISTEN:
+    while ( !$restart ) {
+        while ( accept( Remote, $daemon ) ) {
+            DEBUG && warn "New connection\n";
 
-        # Ignore broken pipes as an HTTP server should
-        local $SIG{PIPE} = sub { close Remote };
-        local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );
+            select Remote;
 
-        local *STDIN  = \*Remote;
-        local *STDOUT = \*Remote;
-        select STDOUT;
+            Remote->blocking(1);
 
-        # 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";
+            # Read until we see all headers
+            $self->{inputbuf} = '';
 
-        STDIN->blocking(1);
+            if ( !$self->_read_headers ) {
+                # Error reading, give up
+                close Remote;
+                next LISTEN;
+            }
 
-        # 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/;
+            my ( $method, $uri, $protocol ) = $self->_parse_request_line;
 
-        # We better be careful and just use 1.0
-        $protocol = '1.0';
+            DEBUG && warn "Parsed request: $method $uri $protocol\n";
+            next unless $method;
 
-        my ( $path, $query_string ) = split /\?/, $uri, 2;
+            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 {
+                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} };
+    }
+
+    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    => $peeraddr,
-            REMOTE_HOST    => $peername,
-            REQUEST_METHOD => $method       || '',
-            SERVER_NAME    => $localname,
-            SERVER_PORT    => $port,
+            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",
-            %ENV,
+            %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;
-                }
-            }
+            $self->_parse_headers;
         }
 
         # Pass flow control to Catalyst
         $class->handle_request;
-        exit if defined $pid;
-    }
-    continue {
-        close Remote;
-    }
-    close HTTPDaemon;
+    
+        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;
+                }
 
-    if ($GOT_HUP) {
-        $SIG{CHLD} = 'DEFAULT';
-        exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @ARGV );
+                ( $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";
+        }
+        
+        last REQUEST;
     }
+    
+    DEBUG && warn "Closing connection\n";
+
+    close Remote;
 }
 
-sub _compare_index {
-    my ( $one, $two ) = @_;
-    my %clone = %$two;
-    my @changes;
-    while ( my ( $key, $val ) = each %$one ) {
-        if ( !$clone{$key} || ( $clone{$key} ne $val ) ) {
-            push @changes, $key;
+sub _read_headers {
+    my $self = shift;
+
+    while (1) {
+        my $read = sysread Remote, my $buf, CHUNKSIZE;
+
+        if ( !defined $read ) {
+            next if $! == EWOULDBLOCK;
+            DEBUG && warn "Error reading headers: $!\n";
+            return;
+        } elsif ( $read == 0 ) {
+            DEBUG && warn "EOF\n";
+            return;
         }
-        delete $clone{$key};
+
+        DEBUG && warn "Read $read bytes\n";
+        $self->{inputbuf} .= $buf;
+        last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s;
     }
-    for my $key ( keys %clone ) { push @changes, $key }
-    return \@changes;
-}
 
-sub _get_line {
-    my ( $self, $handle ) = @_;
+    return 1;
+}
 
-    my $line = '';
+sub _parse_request_line {
+    my $self = shift;
 
-    while ( sysread( $handle, my $byte, 1 ) ) {
-        last if $byte eq "\012";    # eol
-        $line .= $byte;
+    # Parse request line
+    if ( $self->{inputbuf} !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) {
+        return ();
     }
 
-    1 while $line =~ s/\s\z//;
+    my $method = $1;
+    my $uri    = $2;
+    my $proto  = $3 || 'HTTP/0.9';
 
-    return $line;
+    return ( $method, $uri, $proto );
 }
 
-sub _index {
-    my ( $dir, $regex ) = @_;
-    my %index;
-    finddepth(
-        {
-            wanted => sub {
-                my $file = File::Spec->rel2abs($File::Find::name);
-                return unless $file =~ /$regex/;
-                return unless -f $file;
-                my $time = ( stat $file )[9];
-                $index{$file} = $time;
-            },
-            no_chdir => 1
-        },
-        $dir
-    );
-    return \%index;
+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 _test {
-    my $file = shift;
-    local $SIG{__WARN__} = sub { };
-    open my $olderr, '>&STDERR';
-    open STDERR, '>', File::Spec->devnull;
-    eval "require '$file'";
-    open STDERR, '>&', $olderr;
-    return $@ if $@;
-    return 0;
+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;
 }
 
-=back
+sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
+
+no Moose;
 
 =head1 SEE ALSO
 
@@ -342,6 +537,10 @@ Sebastian Riedel, <sri@cpan.org>
 
 Dan Kubb, <dan.kubb-cpan@onautopilot.com>
 
+Sascha Kiefer, <esskar@cpan.org>
+
+Andy Grundman, <andy@hybridized.org>
+
 =head1 THANKS
 
 Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.