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;