1package Catalyst::Engine::HTTP::Prefork::Handler; 2 3use strict; 4use base 'Catalyst::Engine::CGI'; 5 6use CGI::Cookie::XS; 7use Data::Dump qw(dump); 8use HTTP::Body; 9use HTTP::Date qw(time2str); 10use HTTP::Headers; 11use HTTP::Status qw(status_message); 12use IO::Socket qw(:crlf); 13 14use constant DEBUG => $ENV{CATALYST_PREFORK_DEBUG} || 0; 15use constant CHUNKSIZE => 64 * 1024; 16 17sub new { 18 my ( $class, $server ) = @_; 19 20 bless { 21 client => {}, 22 server => $server, 23 }, $class; 24} 25 26sub prepare_request { 27 my ( $self, $c, $client ) = @_; 28 29 $self->{client} = $client; 30} 31 32sub prepare_headers { 33 my ( $self, $c ) = @_; 34 35 # Save time by not bothering to stuff headers in %ENV 36 $c->req->headers( 37 HTTP::Headers->new( %{ $self->{client}->{headers} } ) 38 ); 39} 40 41sub prepare_cookies { 42 my ( $self, $c ) = @_; 43 44 if ( my $header = $c->request->header('Cookie') ) { 45 # This method is around 8x faster than letting 46 # CGI::Simple::Cookie do the parsing in pure perl 47 my $cookies = CGI::Cookie::XS->parse( $header ); 48 my $cookie_objs = { 49 map { 50 $_ => bless { 51 name => $_, 52 path => '/', 53 value => $cookies->{ $_ }, 54 }, 'CGI::Simple::Cookie'; 55 } keys %{ $cookies } 56 }; 57 58 $c->req->cookies( $cookie_objs ); 59 } 60} 61 62# We need to override prepare_body for chunked request support. 63# This should probably move to Catalyst at some point. 64sub prepare_body { 65 my ( $self, $c ) = @_; 66 67 my $te = $c->request->header('Transfer-Encoding'); 68 69 if ( $te && $te =~ /^chunked$/i ) { 70 DEBUG && warn "[$$] Body data is chunked\n"; 71 $self->{_chunked_req} = 1; 72 } 73 else { 74 # We can use the normal prepare_body method for a non-chunked body 75 return $self->SUPER::prepare_body( $c ); 76 } 77 78 unless ( $c->request->{_body} ) { 79 my $type = $c->request->header('Content-Type'); 80 # with no length, HTTP::Body 1.00+ will treat the content 81 # as chunked 82 $c->request->{_body} = HTTP::Body->new( $type ); 83 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp} 84 if exists $c->config->{uploadtmp}; 85 } 86 87 while ( my $buffer = $self->read($c) ) { 88 $c->prepare_body_chunk($buffer); 89 } 90 91 $self->finalize_read($c); 92} 93 94sub read { 95 my ( $self, $c, $maxlength ) = @_; 96 97 # If the request is not chunked, we can use the normal read method 98 if ( !$self->{_chunked_req} ) { 99 return $self->SUPER::read( $c, $maxlength ); 100 } 101 102 # If HTTP::Body says we're done, don't read 103 if ( $c->request->{_body}->state eq 'done' ) { 104 return; 105 } 106 107 my $rc = $self->read_chunk( $c, my $buffer, CHUNKSIZE ); 108 if ( defined $rc ) { 109 return $buffer; 110 } 111 else { 112 Catalyst::Exception->throw( 113 message => "Unknown error reading input: $!" ); 114 } 115} 116 117sub read_chunk { 118 my $self = shift; 119 my $c = shift; 120 121 my $read; 122 123 # If we have any remaining data in the input buffer, send it back first 124 if ( $_[0] = $self->{client}->{inputbuf} ) { 125 $read = length( $_[0] ); 126 $self->{client}->{inputbuf} = ''; 127 128 # XXX: Data::Dump segfaults on 5.8.8 when dumping long strings... 129 DEBUG && warn "[$$] read_chunk: Read $read bytes from previous input buffer\n"; # . dump($_[0]) . "\n"; 130 } 131 else { 132 $read = $self->SUPER::read_chunk( $c, @_ ); 133 DEBUG && warn "[$$] read_chunk: Read $read bytes from STDIN\n"; # . dump($_[0]) . "\n"; 134 } 135 136 return $read; 137} 138 139sub finalize_read { 140 my ( $self, $c ) = @_; 141 142 delete $self->{_chunked_req}; 143 144 return $self->SUPER::finalize_read( $c ); 145} 146 147sub finalize_headers { 148 my ( $self, $c ) = @_; 149 150 my $protocol = $c->request->protocol; 151 my $status = $c->response->status; 152 my $message = status_message($status); 153 154 my @headers; 155 push @headers, "$protocol $status $message"; 156 157 # Switch on Transfer-Encoding: chunked if we don't know Content-Length. 158 if ( $protocol eq 'HTTP/1.1' ) { 159 if ( !$c->response->content_length ) { 160 if ( $c->response->status !~ /^1\d\d|[23]04$/ ) { 161 DEBUG && warn "[$$] Using chunked transfer-encoding to send unknown length body\n"; 162 $c->response->header( 'Transfer-Encoding' => 'chunked' ); 163 $self->{_chunked_res} = 1; 164 } 165 } 166 elsif ( my $te = $c->response->header('Transfer-Encoding') ) { 167 if ( $te eq 'chunked' ) { 168 DEBUG && warn "[$$] Chunked transfer-encoding set for response\n"; 169 $self->{_chunked_res} = 1; 170 } 171 } 172 } 173 174 if ( !$c->response->header('Date') ) { 175 $c->response->header( Date => time2str( time() ) ); 176 } 177 178 $c->response->header( Status => $c->response->status ); 179 180 # Should we keep the connection open? 181 if ( $self->{client}->{keepalive} ) { 182 $c->response->headers->header( Connection => 'keep-alive' ); 183 } 184 else { 185 $c->response->headers->header( Connection => 'close' ); 186 } 187 188 push @headers, $c->response->headers->as_string($CRLF); 189 190 # Buffer the headers so they are sent with the first write() call 191 # This reduces the number of TCP packets we are sending 192 $self->{_header_buf} = join( $CRLF, @headers, '' ); 193} 194 195sub finalize_body { 196 my ( $self, $c ) = @_; 197 198 $self->SUPER::finalize_body( $c ); 199 200 if ( $self->{_chunked_res} ) { 201 if ( !$self->{_chunked_done} ) { 202 # Write the final '0' chunk 203 syswrite STDOUT, "0$CRLF"; 204 } 205 206 delete $self->{_chunked_res}; 207 delete $self->{_chunked_done}; 208 } 209} 210 211sub write { 212 my ( $self, $c, $buffer ) = @_; 213 214 if ( $self->{_chunked_res} ) { 215 my $len = length($buffer); 216 217 $buffer = sprintf( "%x", $len ) . $CRLF . $buffer . $CRLF; 218 219 # Flag if we wrote an empty chunk 220 if ( !$len ) { 221 $self->{_chunked_done} = 1; 222 } 223 } 224 225 DEBUG && warn "[$$] Wrote " . length($buffer) . " bytes\n"; 226 227 $self->SUPER::write( $c, $buffer ); 228} 229 2301;