File Coverage

blib/lib/Mojo/Server/FastCGI.pm
Criterion Covered Total %
statement 12 163 7.3
branch 0 86 0.0
condition 1 33 3.0
subroutine 4 16 25.0
pod 10 10 100.0
total 27 308 8.7


line stmt bran cond sub pod time code
1             package Mojo::Server::FastCGI;
2 1     1   974 use Mojo::Base 'Mojo::Server';
  1         3  
  1         9  
3              
4 1     1   89411 use Errno qw/EAGAIN EINTR EWOULDBLOCK/;
  1         2  
  1         152  
5 1     1   1068 use IO::Socket;
  1         15829  
  1         6  
6              
7 1   50 1   778 use constant DEBUG => $ENV{MOJO_FASTCGI_DEBUG} || 0;
  1         3  
  1         2655  
8              
9             our $VERSION = '0.41';
10              
11             # Roles
12             my @ROLES = qw/RESPONDER AUTHORIZER FILTER/;
13             my %ROLE_NUMBERS;
14             {
15             my $i = 1;
16             for my $role (@ROLES) {
17             $ROLE_NUMBERS{$role} = $i;
18             $i++;
19             }
20             }
21              
22             # Types
23             my @TYPES = qw/
24             BEGIN_REQUEST
25             ABORT_REQUEST
26             END_REQUEST
27             PARAMS
28             STDIN
29             STDOUT
30             STDERR
31             DATA
32             GET_VALUES
33             GET_VALUES_RESULT
34             UNKNOWN_TYPE
35             /;
36             my %TYPE_NUMBERS;
37             {
38             my $i = 1;
39             for my $type (@TYPES) {
40             $TYPE_NUMBERS{$type} = $i;
41             $i++;
42             }
43             }
44              
45             # "Wow! Homer must have got one of those robot cars!
46             # *Car crashes in background*
47             # Yeah, one of those AMERICAN robot cars."
48             sub accept_connection {
49 0     0 1   my $self = shift;
50              
51             # Listen socket
52 0 0         unless ($self->{listen}) {
53 0           my $listen = IO::Socket->new;
54              
55             # Open
56 0 0         unless ($listen->fdopen(0, 'r')) {
57 0           $self->app->log->error("Can't open FastCGI socket fd0: $!");
58 0           return;
59             }
60              
61 0           $self->{listen} = $listen;
62             }
63 0           $self->app->log->debug('FastCGI listen socket opened.') if DEBUG;
64              
65             # Accept
66 0           my $c;
67 0 0         unless ($c = $self->{listen}->accept) {
68 0           $self->app->log->error("Can't accept FastCGI connection: $!");
69 0           return;
70             }
71 0           $self->app->log->debug('Accepted FastCGI connection.') if DEBUG;
72              
73 0           return $c;
74             }
75              
76             sub read_record {
77 0     0 1   my ($self, $c) = @_;
78 0 0         return unless $c;
79              
80             # Header
81 0           my $header = $self->_read_chunk($c, 8);
82 0 0         return unless $header;
83 0           my ($version, $type, $id, $clen, $plen) = unpack 'CCnnC', $header;
84              
85             # Body
86 0           my $body = $self->_read_chunk($c, $clen + $plen);
87              
88             # No content, just paddign bytes
89 0 0         $body = undef unless $clen;
90              
91             # Ignore padding bytes
92 0 0         $body = $plen ? substr($body, 0, $clen, '') : $body;
93              
94 0           if (DEBUG) {
95             my $t = $self->type_name($type);
96             $self->app->log->debug(
97             qq/Reading FastCGI record: $type - $id - "$body"./);
98             }
99              
100 0           return $self->type_name($type), $id, $body;
101             }
102              
103             sub read_request {
104 0     0 1   my ($self, $c) = @_;
105 0           $self->app->log->debug('Reading FastCGI request.') if DEBUG;
106              
107             # Transaction
108 0 0         my $tx =
109             $self->can('build_tx')
110             ? $self->build_tx
111             : $self->on_transaction->($self);
112 0           $tx->connection($c);
113 0           my $req = $tx->req;
114              
115             # Type
116 0           my ($type, $id, $body) = $self->read_record($c);
117 0 0 0       unless ($type && $type eq 'BEGIN_REQUEST') {
118 0           $self->app->log->info("First FastCGI record wasn't a begin request.");
119 0           return;
120             }
121 0           $ENV{FCGI_ID} = $tx->{fcgi_id} = $id;
122              
123             # Role/Flags
124 0           my ($role, $flags) = unpack 'nC', $body;
125 0           $ENV{FCGI_ROLE} = $tx->{fcgi_role} = $self->role_name($role);
126              
127             # Slurp
128 0           my $buffer = '';
129 0           my $env = {};
130 0           while (($type, $id, $body) = $self->read_record($c)) {
131              
132             # Wrong id
133 0 0         next unless $id == $tx->{fcgi_id};
134              
135             # Params
136 0 0         if ($type eq 'PARAMS') {
    0          
137              
138             # Normal param chunk
139 0 0         if ($body) {
140 0           $buffer .= $body;
141 0           next;
142             }
143              
144             # Params done
145 0           while (length $buffer) {
146              
147             # Name and value length
148 0           my $name_len = $self->_nv_length(\$buffer);
149 0           my $value_len = $self->_nv_length(\$buffer);
150              
151             # Name and value
152 0           my $name = substr $buffer, 0, $name_len, '';
153 0           my $value = substr $buffer, 0, $value_len, '';
154              
155             # Environment
156 0           $env->{$name} = $value;
157 0           $self->app->log->debug(qq/FastCGI param: $name - "$value"./)
158             if DEBUG;
159              
160             # Store connection information
161 0 0         $tx->remote_address($value) if $name =~ /REMOTE_ADDR/i;
162 0 0         $tx->local_port($value) if $name =~ /SERVER_PORT/i;
163             }
164             }
165              
166             # Stdin
167             elsif ($type eq 'STDIN') {
168              
169             # Environment
170 0 0         if (keys %$env) {
171 0           $req->parse($env);
172 0           $env = {};
173             }
174              
175             # EOF
176 0 0         last unless $body;
177              
178             # Chunk
179 0           $req->parse($body);
180              
181             # Error
182 0 0         return $tx if $req->error;
183             }
184             }
185              
186 0           return $tx;
187             }
188              
189             sub role_name {
190 0     0 1   my ($self, $role) = @_;
191 0 0         return unless $role;
192 0           return $ROLES[$role - 1];
193             }
194              
195             sub role_number {
196 0     0 1   my ($self, $role) = @_;
197 0 0         return unless $role;
198 0           return $ROLE_NUMBERS{uc $role};
199             }
200              
201             sub run {
202 0     0 1   my $self = shift;
203              
204             # Preload application
205 0           $self->app;
206              
207             # New incoming request
208 0           while (my $c = $self->accept_connection) {
209              
210             # Request
211 0           my $tx = $self->read_request($c);
212              
213             # Error
214 0 0         unless ($tx) {
215 0           $self->app->log->info("No transaction for FastCGI request.");
216 0           next;
217             }
218              
219             # Handle
220 0           $self->app->log->debug('Handling FastCGI request.') if DEBUG;
221 0 0         $self->can('emit')
222             ? $self->emit(request => $tx)
223             : $self->on_request->($self, $tx);
224              
225             # Response
226 0           $self->write_response($tx);
227              
228             # Finish transaction
229 0           $tx->server_close;
230             }
231             }
232              
233             sub type_name {
234 0     0 1   my ($self, $type) = @_;
235 0 0         return unless $type;
236 0           return $TYPES[$type - 1];
237             }
238              
239             sub type_number {
240 0     0 1   my ($self, $type) = @_;
241 0 0         return unless $type;
242 0           return $TYPE_NUMBERS{uc $type};
243             }
244              
245             sub write_records {
246 0     0 1   my ($self, $c, $type, $id, $body) = @_;
247 0 0 0       return unless defined $c && defined $type && defined $id;
      0        
248 0   0       $body //= '';
249              
250             # Write records
251 0 0         my $empty = $body ? 0 : 1;
252 0           my $offset = 0;
253 0           my $body_len = length $body;
254 0   0       while (($body_len > 0) || $empty) {
255              
256             # Need to split content
257 0 0         my $payload_len = $body_len > 32 * 1024 ? 32 * 1024 : $body_len;
258 0           my $pad_len = (8 - ($payload_len % 8)) % 8;
259              
260             # FCGI version 1 record
261 0           my $template = "CCnnCxa${payload_len}x$pad_len";
262              
263 0           if (DEBUG) {
264             my $chunk = substr($body, $offset, $payload_len);
265             $self->app->log->debug(
266             qq/Writing FastCGI record: $type - $id - "$chunk"./);
267             }
268              
269             # Write whole record
270 0           my $record = pack $template, 1, $self->type_number($type), $id,
271             $payload_len,
272             $pad_len,
273             substr($body, $offset, $payload_len);
274 0           my $woffset = 0;
275 0           while ($woffset < length $record) {
276 0           my $written = $c->syswrite($record, undef, $woffset);
277              
278             # Error
279 0 0         unless (defined $written) {
280              
281             # Retry
282 0 0 0       next if $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK;
      0        
283              
284             # Write error
285 0           return;
286             }
287              
288 0           $woffset += $written;
289             }
290 0           $body_len -= $payload_len;
291 0           $offset += $payload_len;
292              
293             # Done
294 0 0         last if $empty;
295             }
296              
297 0           return 1;
298             }
299              
300             sub write_response {
301 0     0 1   my ($self, $tx) = @_;
302 0           $self->app->log->debug('Writing FastCGI response.') if DEBUG;
303              
304             # Status
305 0           my $res = $tx->res;
306 0   0       my $code = $res->code || 404;
307 0   0       my $message = $res->message || $res->default_message;
308 0 0         $res->headers->status("$code $message") unless $res->headers->status;
309              
310             # Fix headers
311 0           $res->fix_headers;
312              
313             # Headers
314 0           my $c = $tx->connection;
315 0           my $offset = 0;
316 0           while (1) {
317 0           my $chunk = $res->get_header_chunk($offset);
318              
319             # No headers yet, try again
320 0 0         unless (defined $chunk) {
321 0           sleep 1;
322 0           next;
323             }
324              
325             # End of headers
326 0 0         last unless length $chunk;
327              
328             # Headers
329 0           $offset += length $chunk;
330             return
331 0 0         unless $self->write_records($c, 'STDOUT', $tx->{fcgi_id}, $chunk);
332             }
333              
334             # Body
335 0           $offset = 0;
336 0           while (1) {
337 0           my $chunk = $res->get_body_chunk($offset);
338              
339             # No content yet, try again
340 0 0         unless (defined $chunk) {
341 0           sleep 1;
342 0           next;
343             }
344              
345             # End of content
346 0 0         last unless length $chunk;
347              
348             # Content
349 0           $offset += length $chunk;
350             return
351 0 0         unless $self->write_records($c, 'STDOUT', $tx->{fcgi_id}, $chunk);
352             }
353              
354             # The end
355             return
356 0 0         unless $self->write_records($c, 'STDOUT', $tx->{fcgi_id}, undef);
357             return
358 0 0         unless $self->write_records($c, 'END_REQUEST', $tx->{fcgi_id},
359             pack('CCCCCCCC', 0));
360             }
361              
362             sub _nv_length {
363 0     0     my ($self, $bodyref) = @_;
364              
365             # Try first byte
366 0           my $len = unpack 'C', substr($$bodyref, 0, 1, '');
367              
368             # 4 byte length
369 0 0         if ($len & 0x80) {
370 0           $len = pack 'C', $len & 0x7F;
371 0           substr $len, 1, 0, substr($$bodyref, 0, 3, '');
372 0           $len = unpack 'N', $len;
373             }
374              
375 0           return $len;
376             }
377              
378             sub _read_chunk {
379 0     0     my ($self, $c, $len) = @_;
380              
381             # Read
382 0           my $chunk = '';
383 0           while (length $chunk < $len) {
384 0           my $read = $c->sysread(my $buffer, $len - length $chunk, 0);
385 0 0         unless (defined $read) {
386 0 0 0       next if $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK;
      0        
387 0           last;
388             }
389 0 0         last unless $read;
390 0           $chunk .= $buffer;
391             }
392              
393 0           return $chunk;
394             }
395              
396             1;
397             __END__