root/trunk/lib/Perlbal/ClientHTTPBase.pm @ 725

Revision 725, 27.5 kB (checked in by hachi, 2 years ago)

Add observed_ip_string attribute to Perlbal::Socket objects. This is for AccessControl plugin (and possibly other things) to use an IP address derived from X-Forwarded-For headers, as opposed to the real peer IP address.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1######################################################################
2# Common HTTP functionality for ClientProxy and ClientHTTP
3# possible states:
4#   reading_headers (initial state, then follows one of two paths)
5#     wait_backend, backend_req_sent, wait_res, xfer_res, draining_res
6#     wait_stat, wait_open, xfer_disk
7# both paths can then go into persist_wait, which means they're waiting
8# for another request from the user
9#
10# Copyright 2004, Danga Interactive, Inc.
11# Copyright 2005-2007, Six Apart, Ltd.
12
13package Perlbal::ClientHTTPBase;
14use strict;
15use warnings;
16no  warnings qw(deprecated);
17
18use Sys::Syscall;
19use base "Perlbal::Socket";
20use HTTP::Date ();
21use fields ('service',             # Perlbal::Service object
22            'replacement_uri',     # URI to send instead of the one requested; this is used
23                                   # to instruct _serve_request to send an index file instead
24                                   # of trying to serve a directory and failing
25            'scratch',             # extra storage; plugins can use it if they want
26
27            # reproxy support
28            'reproxy_file',        # filename the backend told us to start opening
29            'reproxy_file_size',   # size of file, once we stat() it
30            'reproxy_fh',          # if needed, IO::Handle of fd
31            'reproxy_file_offset', # how much we've sent from the file.
32
33            'post_sendfile_cb',    # subref to run after we're done sendfile'ing the current file
34
35            'requests',            # number of requests this object has performed for the user
36
37            # service selector parent
38            'selector_svc',        # the original service from which we came
39            );
40
41use Fcntl ':mode';
42use Errno qw( EPIPE ECONNRESET );
43use POSIX ();
44
45# hard-code defaults can be changed with MIME management command
46our $MimeType = {qw(
47                    css  text/css
48                    doc  application/msword
49                    gif  image/gif
50                    htm  text/html
51                    html text/html
52                    jpg  image/jpeg
53                    js   application/x-javascript
54                    mp3  audio/mpeg
55                    mpg  video/mpeg
56                    pdf  application/pdf
57                    png  image/png
58                    tif   image/tiff
59                    tiff  image/tiff
60                    torrent  application/x-bittorrent
61                    txt   text/plain
62                    zip   application/zip
63)};
64
65# ClientHTTPBase
66sub new {
67    my ($class, $service, $sock, $selector_svc) = @_;
68
69    my $self = $class;
70    $self = fields::new($class) unless ref $self;
71    $self->SUPER::new($sock);       # init base fields
72
73    $self->{service}         = $service;
74    $self->{replacement_uri} = undef;
75    $self->{headers_string}  = '';
76    $self->{requests}        = 0;
77    $self->{scratch}         = {};
78    $self->{selector_svc}    = $selector_svc;
79
80    $self->state('reading_headers');
81
82    bless $self, ref $class || $class;
83    $self->watch_read(1);
84    return $self;
85}
86
87sub close {
88    my Perlbal::ClientHTTPBase $self = shift;
89
90    # don't close twice
91    return if $self->{closed};
92
93    # could contain a closure with circular reference
94    $self->{post_sendfile_cb} = undef;
95
96    # close the file we were reproxying, if any
97    CORE::close($self->{reproxy_fh}) if $self->{reproxy_fh};
98
99    # now pass up the line
100    $self->SUPER::close(@_);
101}
102
103# given the response headers we just got, and considering our request
104# headers, determine if we should be sending keep-alive header
105# information back to the client
106sub setup_keepalive {
107    my Perlbal::ClientHTTPBase $self = $_[0];
108    print "ClientHTTPBase::setup_keepalive($self)\n" if Perlbal::DEBUG >= 2;
109
110    # now get the headers we're using
111    my Perlbal::HTTPHeaders $reshd = $_[1];
112    my Perlbal::HTTPHeaders $rqhd = $self->{req_headers};
113
114    # for now, we enforce outgoing HTTP 1.0
115    $reshd->set_version("1.0");
116
117    # if we came in via a selector service, that's whose settings
118    # we respect for persist_client
119    my $svc = $self->{selector_svc} || $self->{service};
120    my $persist_client = $svc->{persist_client} || 0;
121    print "  service's persist_client = $persist_client\n" if Perlbal::DEBUG >= 3;
122
123    # do keep alive if they sent content-length or it's a head request
124    my $do_keepalive = $persist_client && $rqhd->req_keep_alive($reshd);
125    if ($do_keepalive) {
126        print "  doing keep-alive to client\n" if Perlbal::DEBUG >= 3;
127        my $timeout = $self->{service}->{persist_client_timeout};
128        $reshd->header('Connection', 'keep-alive');
129        $reshd->header('Keep-Alive', $timeout ? "timeout=$timeout, max=100" : undef);
130    } else {
131        print "  doing connection: close\n" if Perlbal::DEBUG >= 3;
132        # FIXME: we don't necessarily want to set connection to close,
133        # but really set a space-separated list of tokens which are
134        # specific to the connection.  "close" and "keep-alive" are
135        # just special.
136        $reshd->header('Connection', 'close');
137        $reshd->header('Keep-Alive', undef);
138    }
139}
140
141# overridden here from Perlbal::Socket to use the service value
142sub max_idle_time {
143    return $_[0]->{service}->{persist_client_timeout};
144}
145
146# called when we've finished writing everything to a client and we need
147# to reset our state for another request.  returns 1 to mean that we should
148# support persistence, 0 means we're discarding this connection.
149sub http_response_sent {
150    my Perlbal::ClientHTTPBase $self = $_[0];
151
152    # close if we're supposed to
153    if (
154        ! defined $self->{res_headers} ||
155        ! $self->{res_headers}->res_keep_alive($self->{req_headers}) ||
156        $self->{do_die}
157        )
158    {
159        # do a final read so we don't have unread_data_waiting and RST
160        # the connection.  IE and others send an extra \r\n after POSTs
161        my $dummy = $self->read(5);
162
163        # close if we have no response headers or they say to close
164        $self->close("no_keep_alive");
165        return 0;
166    }
167
168    # if they just did a POST, set the flag that says we might expect
169    # an unadvertised \r\n coming from some browsers.  Old Netscape
170    # 4.x did this on all POSTs, and Firefox/Safari do it on
171    # XmlHttpRequest POSTs.
172    if ($self->{req_headers}->request_method eq "POST") {
173        $self->{ditch_leading_rn} = 1;
174    }
175
176    # now since we're doing persistence, uncork so the last packet goes.
177    # we will recork when we're processing a new request.
178    $self->tcp_cork(0);
179
180    # reset state
181    $self->{replacement_uri} = undef;
182    $self->{headers_string} = '';
183    $self->{req_headers} = undef;
184    $self->{res_headers} = undef;
185    $self->{reproxy_fh} = undef;
186    $self->{reproxy_file} = undef;
187    $self->{reproxy_file_size} = 0;
188    $self->{reproxy_file_offset} = 0;
189    $self->{read_buf} = [];
190    $self->{read_ahead} = 0;
191    $self->{read_size} = 0;
192    $self->{scratch} = {};
193    $self->{post_sendfile_cb} = undef;
194    $self->state('persist_wait');
195
196    if (my $selector_svc = $self->{selector_svc}) {
197        if (! $selector_svc->run_hook('return_to_base', $self)){
198            $selector_svc->return_to_base($self);
199        }
200    }
201
202    # NOTE: because we only speak 1.0 to clients they can't have
203    # pipeline in a read that we haven't read yet.
204    $self->watch_read(1);
205    $self->watch_write(0);
206    return 1;
207}
208
209sub reproxy_fh {
210    my Perlbal::ClientHTTPBase $self = shift;
211
212    # setter
213    if (@_) {
214        my ($fh, $size) = @_;
215        $self->state('xfer_disk');
216        $self->{reproxy_fh} = $fh;
217        $self->{reproxy_file_offset} = 0;
218        $self->{reproxy_file_size} = $size;
219        # call hook that we're reproxying a file
220        return $fh if $self->{service}->run_hook("start_send_file", $self);
221        # turn on writes (the hook might not have wanted us to)
222        $self->watch_write(1);
223        return $fh;
224    }
225
226    return $self->{reproxy_fh};
227}
228
229sub event_read {
230    my Perlbal::ClientHTTPBase $self = shift;
231
232    # see if we have headers?
233    die "Shouldn't get here!  This is an abstract base class, pretty much, except in the case of the 'selector' role."
234        if $self->{req_headers};
235
236    my $hd = $self->read_request_headers;
237    return unless $hd;
238
239    return if $self->{service}->run_hook('start_http_request', $self);
240
241    # we must stop watching for events now, otherwise if there's
242    # PUT/POST overflow, it'll be sent to ClientHTTPBase, which can't
243    # handle it yet.  must wait for the selector (which has as much
244    # time as it wants) to route as to our subclass, which can then
245    # renable reads.
246    $self->watch_read(0);
247
248    my $select = sub {
249        # now that we have headers, it's time to tell the selector
250        # plugin that it's time for it to select which real service to
251        # use
252        my $selector = $self->{'service'}->selector();
253        return $self->_simple_response(500, "No service selector configured.")
254            unless ref $selector eq "CODE";
255        $selector->($self);
256    };
257
258    my $svc = $self->{'service'};
259    if ($svc->{latency}) {
260        Danga::Socket->AddTimer($svc->{latency} / 1000, $select);
261    } else {
262        $select->();
263    }
264}
265
266# client is ready for more of its file.  so sendfile some more to it.
267# (called by event_write when we're actually in this mode)
268sub event_write_reproxy_fh {
269    my Perlbal::ClientHTTPBase $self = shift;
270
271    my $remain = $self->{reproxy_file_size} - $self->{reproxy_file_offset};
272    $self->tcp_cork(1) if $self->{reproxy_file_offset} == 0;
273
274    # cap at 128k sendfiles
275    my $to_send = $remain > 128 * 1024 ? 128 * 1024 : $remain;
276
277    $self->watch_write(0);
278
279    my $postread = sub {
280        return if $self->{closed};
281
282        my $sent = Perlbal::Socket::sendfile($self->{fd},
283                                             fileno($self->{reproxy_fh}),
284                                             $to_send);
285        #warn "to_send = $to_send, sent = $sent\n";
286        print "REPROXY Sent: $sent\n" if Perlbal::DEBUG >= 2;
287
288        if ($sent < 0) {
289            return $self->close("epipe")     if $! == EPIPE;
290            return $self->close("connreset") if $! == ECONNRESET;
291            print STDERR "Error w/ sendfile: $!\n";
292            $self->close('sendfile_error');
293            return;
294        }
295        $self->{reproxy_file_offset} += $sent;
296
297        if ($sent >= $remain) {
298            return if $self->{service}->run_hook('reproxy_fh_finished', $self);
299
300            # close the sendfile fd
301            CORE::close($self->{reproxy_fh});
302
303            $self->{reproxy_fh} = undef;
304            if (my $cb = $self->{post_sendfile_cb}) {
305                $cb->();
306            } else {
307                $self->http_response_sent;
308            }
309        } else {
310            $self->watch_write(1);
311        }
312    };
313
314    # TODO: way to bypass readahead and go straight to sendfile for common/hot/recent files.
315    # something like:
316    # if ($hot) { $postread->(); return ; }
317
318    if ($to_send < 0) {
319        Perlbal::log('warning', "tried to readahead negative bytes.  filesize=$self->{reproxy_file_size}, offset=$self->{reproxy_file_offset}");
320        # this code, doing sendfile, will fail gracefully with return
321        # code, not 'die', and we'll close with sendfile_error:
322        $postread->();
323        return;
324    }
325
326    Perlbal::AIO::set_file_for_channel($self->{reproxy_file});
327    Perlbal::AIO::aio_readahead($self->{reproxy_fh},
328                                $self->{reproxy_file_offset},
329                                $to_send, $postread);
330}
331
332sub event_write {
333    my Perlbal::ClientHTTPBase $self = shift;
334
335    # Any HTTP client is considered alive if it's writable.
336    # if it's not writable for 30 seconds, we kill it.
337    # subclasses can decide what's appropriate for timeout.
338    $self->{alive_time} = $Perlbal::tick_time;
339
340    # if we're sending a filehandle, go do some more sendfile:
341    if ($self->{reproxy_fh}) {
342        $self->event_write_reproxy_fh;
343        return;
344    }
345
346    # otherwise just kick-start our write buffer.
347    if ($self->write(undef)) {
348        # we've written all data in the queue, so stop waiting for
349        # write notifications:
350        print "All writing done to $self\n" if Perlbal::DEBUG >= 2;
351        $self->watch_write(0);
352    }
353}
354
355# this gets called when a "web" service is serving a file locally.
356sub _serve_request {
357    my Perlbal::ClientHTTPBase $self = shift;
358    my Perlbal::HTTPHeaders $hd = shift;
359
360    my $rm = $hd->request_method;
361    unless ($rm eq "HEAD" || $rm eq "GET") {
362        return $self->_simple_response(403, "Unimplemented method");
363    }
364
365    my $uri = Perlbal::Util::durl($self->{replacement_uri} || $hd->request_uri);
366    my Perlbal::Service $svc = $self->{service};
367
368    # start_serve_request hook
369    return 1 if $self->{service}->run_hook('start_serve_request', $self, \$uri);
370
371    # don't allow directory traversal
372    if ($uri =~ m!/\.\./! || $uri !~ m!^/!) {
373        return $self->_simple_response(403, "Bogus URL");
374    }
375
376    # double question mark means to serve multiple files, comma separated after the
377    # questions.  the uri part before the question mark is the relative base directory
378    # TODO: only do this if $uri has ?? and the service also allows it.  otherwise
379    # we don't want to mess with anybody's meaning of '??' on the backend service
380    return $self->_serve_request_multiple($hd, $uri) if $uri =~ /\?\?/;
381
382    # chop off the query string
383    $uri =~ s/\?.*//;
384
385    return $self->_simple_response(500, "Docroot unconfigured")
386        unless $svc->{docroot};
387
388    my $file = $svc->{docroot} . $uri;
389
390    # update state, since we're now waiting on stat
391    $self->state('wait_stat');
392
393    Perlbal::AIO::aio_stat($file, sub {
394        # client's gone anyway
395        return if $self->{closed};
396        unless (-e _) {
397            return if $self->{service}->run_hook('static_get_poststat_file_missing', $self);
398            return $self->_simple_response(404);
399        }
400
401        my $mtime   = (stat(_))[9];
402        my $lastmod = HTTP::Date::time2str($mtime);
403        my $ims     = $hd->header("If-Modified-Since") || "";
404
405        # IE sends a request header like "If-Modified-Since: <DATE>; length=<length>"
406        # so we have to remove the length bit before comparing it with our date.
407        # then we save the length to compare later.
408        my $ims_len;
409        if ($ims && $ims =~ s/; length=(\d+)//) {
410            $ims_len = $1;
411        }
412
413        my $not_mod = $ims eq $lastmod && -f _;
414
415        my $res;
416        my $not_satisfiable = 0;
417        my $size = -s _ if -f _;
418
419        # extra protection for IE, since it's offering the info anyway.  (see above)
420        $not_mod = 0 if $ims_len && $ims_len != $size;
421
422        my ($status, $range_start, $range_end) = $hd->range($size);
423
424        if ($not_mod) {
425            $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(304);
426        } elsif ($status == 416) {
427            $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(416);
428            $res->header("Content-Range", $size ? "bytes */$size" : "*");
429            $res->header("Content-Length", 0);
430            $not_satisfiable = 1;
431        } elsif ($status == 206) {
432            # partial content
433            $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(206);
434        } else {
435            return if $self->{service}->run_hook('static_get_poststat_pre_send', $self, $mtime);
436            $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200);
437        }
438
439        # now set whether this is keep-alive or not
440        $res->header("Date", HTTP::Date::time2str());
441        $res->header("Server", "Perlbal");
442        $res->header("Last-Modified", $lastmod);
443
444        if (-f _) {
445            # advertise that we support byte range requests
446            $res->header("Accept-Ranges", "bytes");
447
448            unless ($not_mod || $not_satisfiable) {
449                my ($ext) = ($file =~ /\.(\w+)$/);
450                $res->header("Content-Type",
451                             (defined $ext && exists $MimeType->{$ext}) ? $MimeType->{$ext} : "text/plain");
452
453                unless ($status == 206) {
454                    $res->header("Content-Length", $size);
455                } else {
456                    $res->header("Content-Range", "bytes $range_start-$range_end/$size");
457                    $res->header("Content-Length", $range_end - $range_start + 1);
458                }
459            }
460
461            # has to happen after content-length is set to work:
462            $self->setup_keepalive($res);
463
464            return if $self->{service}->run_hook('modify_response_headers', $self);
465
466            if ($rm eq "HEAD" || $not_mod || $not_satisfiable) {
467                # we can return already, since we know the size
468                $self->tcp_cork(1);
469                $self->state('xfer_resp');
470                $self->write($res->to_string_ref);
471                $self->write(sub { $self->http_response_sent; });
472                return;
473            }
474
475            # state update
476            $self->state('wait_open');
477
478            Perlbal::AIO::aio_open($file, 0, 0, sub {
479                my $rp_fh = shift;
480
481                # if client's gone, just close filehandle and abort
482                if ($self->{closed}) {
483                    CORE::close($rp_fh) if $rp_fh;
484                    return;
485                }
486
487                # handle errors
488                if (! $rp_fh) {
489                    # couldn't open the file we had already successfully stat'ed.
490                    # FIXME: do 500 vs. 404 vs whatever based on $!
491                    return $self->close('aio_open_failure');
492                }
493
494                $self->state('xfer_disk');
495                $self->tcp_cork(1);  # cork writes to self
496                $self->write($res->to_string_ref);
497
498                # seek if partial content
499                if ($status == 206) {
500                    sysseek($rp_fh, $range_start, &POSIX::SEEK_SET);
501                    $size = $range_end - $range_start + 1;
502                }
503
504                $self->{reproxy_file} = $file;
505                $self->reproxy_fh($rp_fh, $size);
506            });
507
508        } elsif (-d _) {
509            $self->try_index_files($hd, $res, $uri);
510        }
511    });
512}
513
514sub _serve_request_multiple {
515    my Perlbal::ClientHTTPBase $self = shift;
516    my ($hd, $uri) = @_;
517
518    my @multiple_files;
519    my %statinfo;  # file -> [ stat fields ]
520
521    # double question mark means to serve multiple files, comma
522    # separated after the questions.  the uri part before the question
523    # mark is the relative base directory
524    my ($base, $list) = ($uri =~ /(.+)\?\?(.+)/);
525
526    unless ($base =~ m!/$!) {
527        return $self->_simple_response(500, "Base directory (before ??) must end in slash.")
528    }
529
530    # and remove any trailing ?.+ on the list, so you can do things like cache busting
531    # with a ?v=<modtime> at the end of a list of files.
532    $list =~ s/\?.+//;
533
534    my Perlbal::Service $svc = $self->{service};
535    return $self->_simple_response(500, "Docroot unconfigured")
536        unless $svc->{docroot};
537
538    @multiple_files = split(/,/, $list);
539
540    return $self->_simple_response(403, "Multiple file serving isn't enabled") unless $svc->{enable_concatenate_get};
541    return $self->_simple_response(403, "Too many files requested") if @multiple_files > 100;
542
543    my $remain = @multiple_files + 1;  # 1 for the base directory
544    my $dirbase = $svc->{docroot} . $base;
545    foreach my $file ('', @multiple_files) {
546        Perlbal::AIO::aio_stat("$dirbase$file", sub {
547            $remain--;
548            $statinfo{$file} = $! ? [] : [ stat(_) ];
549            return if $remain || $self->{closed};
550            $self->_serve_request_multiple_poststat($hd, $dirbase, \@multiple_files, \%statinfo);
551        });
552    }
553}
554
555sub _serve_request_multiple_poststat {
556    my Perlbal::ClientHTTPBase $self = shift;
557    my ($hd, $basedir, $filelist, $stats) = @_;
558
559    # base directory must be a directory
560    unless (S_ISDIR($stats->{''}[2] || 0)) {
561        return $self->_simple_response(404, "Base directory not a directory");
562    }
563
564    # files must all exist
565    my $sum_length      = 0;
566    my $most_recent_mod = 0;
567    my $mime;                  # undef until set, or defaults to text/plain later
568    foreach my $f (@$filelist) {
569        my $stat = $stats->{$f};
570        unless (S_ISREG($stat->[2] || 0)) {
571            return if $self->{service}->run_hook('concat_get_poststat_file_missing', $self);
572            return $self->_simple_response(404, "One or more file does not exist");
573        }
574        if (!$mime && $f =~ /\.(\w+)$/ && $MimeType->{$1}) {
575            $mime = $MimeType->{$1};
576        }
577        $sum_length     += $stat->[7];
578        $most_recent_mod = $stat->[9] if
579            $stat->[9] >$most_recent_mod;
580    }
581    $mime ||= 'text/plain';
582
583    my $lastmod = HTTP::Date::time2str($most_recent_mod);
584    my $ims     = $hd->header("If-Modified-Since") || "";
585
586    # IE sends a request header like "If-Modified-Since: <DATE>; length=<length>"
587    # so we have to remove the length bit before comparing it with our date.
588    # then we save the length to compare later.
589    my $ims_len;
590    if ($ims && $ims =~ s/; length=(\d+)//) {
591        $ims_len = $1;
592    }
593
594    # What is -f _ doing here? don't we detect the existance of all files above in the loop?
595    my $not_mod = $ims eq $lastmod && -f _;
596
597    my $res;
598    if ($not_mod) {
599        $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(304);
600    } else {
601        return if $self->{service}->run_hook('concat_get_poststat_pre_send', $self, $most_recent_mod);
602        $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200);
603        $res->header("Content-Length", $sum_length);
604    }
605
606    $res->header("Date", HTTP::Date::time2str());
607    $res->header("Server", "Perlbal");
608    $res->header("Last-Modified", $lastmod);
609    $res->header("Content-Type",   $mime);
610    # has to happen after content-length is set to work:
611    $self->setup_keepalive($res);
612    return if $self->{service}->run_hook('modify_response_headers', $self);
613
614    if ($hd->request_method eq "HEAD" || $not_mod) {
615        # we can return already, since we know the size
616        $self->tcp_cork(1);
617        $self->state('xfer_resp');
618        $self->write($res->to_string_ref);
619        $self->write(sub { $self->http_response_sent; });
620        return;
621    }
622
623    $self->tcp_cork(1);  # cork writes to self
624    $self->write($res->to_string_ref);
625    $self->state('wait_open');
626
627    # gotta send all files, one by one...
628    my @remain = @$filelist;
629    $self->{post_sendfile_cb} = sub {
630        unless (@remain) {
631            $self->write(sub { $self->http_response_sent; });
632            return;
633        }
634
635        my $file     = shift @remain;
636        my $fullfile = "$basedir$file";
637        my $size     = $stats->{$file}[7];
638
639        Perlbal::AIO::aio_open($fullfile, 0, 0, sub {
640            my $rp_fh = shift;
641
642            # if client's gone, just close filehandle and abort
643            if ($self->{closed}) {
644                CORE::close($rp_fh) if $rp_fh;
645                  return;
646              }
647
648            # handle errors
649            if (! $rp_fh) {
650                # couldn't open the file we had already successfully stat'ed.
651                # FIXME: do 500 vs. 404 vs whatever based on $!
652                return $self->close('aio_open_failure');
653            }
654
655            $self->{reproxy_file}     = $file;
656            $self->reproxy_fh($rp_fh, $size);
657        });
658    };
659    $self->{post_sendfile_cb}->();
660}
661
662sub check_req_headers {
663    my Perlbal::ClientHTTPBase $self = shift;
664    my Perlbal::HTTPHeaders $hds = $self->{req_headers};
665
666    if ($self->{service}->trusted_ip($self->peer_ip_string)) {
667        my @ips = split /,\s*/, ($hds->header("X-Forwarded-For") || '');
668        $self->observed_ip_string($ips[0]) if @ips;
669    }
670
671    return;
672}
673
674sub try_index_files {
675    my Perlbal::ClientHTTPBase $self = shift;
676    my ($hd, $res, $uri, $filepos) = @_;
677
678    # make sure this starts at 0 initially, and fail if it's past the end
679    $filepos ||= 0;
680    if ($filepos >= scalar(@{$self->{service}->{index_files} || []})) {
681        unless ($self->{service}->{dirindexing}) {
682            # just inform them that listing is disabled
683            $self->_simple_response(200, "Directory listing disabled");
684            return;
685        }
686
687        # ensure uri has one and only one trailing slash for better URLs
688        $uri =~ s!/*$!/!;
689
690        # open the directory and create an index
691        my $body = "<html><body>";
692        my $file = $self->{service}->{docroot} . $uri;
693
694        $res->header("Content-Type", "text/html");
695        opendir(D, $file);
696        foreach my $de (sort readdir(D)) {
697            if (-d "$file/$de") {
698                $body .= "<b><a href='$uri$de/'>$de</a></b><br />\n";
699            } else {
700                $body .= "<a href='$uri$de'>$de</a><br />\n";
701            }
702        }
703        closedir(D);
704
705        $body .= "</body></html>";
706        $res->header("Content-Length", length($body));
707        $self->setup_keepalive($res);
708
709        $self->state('xfer_resp');
710        $self->tcp_cork(1);  # cork writes to self
711        $self->write($res->to_string_ref);
712        $self->write(\$body);
713        $self->write(sub { $self->http_response_sent; });
714        return;
715    }
716
717    # construct the file path we need to check
718    my $file = $self->{service}->{index_files}->[$filepos];
719    my $fullpath = $self->{service}->{docroot} . $uri . '/' . $file;
720
721    # now see if it exists
722    Perlbal::AIO::aio_stat($fullpath, sub {
723        return if $self->{closed};
724        return $self->try_index_files($hd, $res, $uri, $filepos + 1) unless -f _;
725
726        # at this point the file exists, so we just want to serve it
727        $self->{replacement_uri} = $uri . '/' . $file;
728        return $self->_serve_request($hd);
729    });
730}
731
732sub _simple_response {
733    my Perlbal::ClientHTTPBase $self = shift;
734    my ($code, $msg) = @_;  # or bodyref
735
736    my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response($code);
737
738    my $body;
739    if ($code != 204 && $code != 304) {
740        $res->header("Content-Type", "text/html");
741        my $en = $res->http_code_english;
742        $body = "<h1>$code" . ($en ? " - $en" : "") . "</h1>\n";
743        $body .= $msg if $msg;
744        $res->header('Content-Length', length($body));
745    }
746
747    $res->header('Server', 'Perlbal');
748
749    $self->setup_keepalive($res);
750
751    $self->state('xfer_resp');
752    $self->tcp_cork(1);  # cork writes to self
753    $self->write($res->to_string_ref);
754    if (defined $body) {
755        unless ($self->{req_headers} && $self->{req_headers}->request_method eq 'HEAD') {
756            # don't write body for head requests
757            $self->write(\$body);
758        }
759    }
760    $self->write(sub { $self->http_response_sent; });
761    return 1;
762}
763
764
765sub send_response {
766    my Perlbal::ClientHTTPBase $self = shift;
767
768    $self->watch_read(0);
769    $self->watch_write(1);
770    return $self->_simple_response(@_);
771}
772
773# method that sends a 500 to the user but logs it and any extra information
774# we have about the error in question
775sub system_error {
776    my Perlbal::ClientHTTPBase $self = shift;
777    my ($msg, $info) = @_;
778
779    # log to syslog
780    Perlbal::log('warning', "system error: $msg ($info)");
781
782    # and return a 500
783    return $self->send_response(500, $msg);
784}
785
786sub event_err {  my $self = shift; $self->close('error'); }
787sub event_hup {  my $self = shift; $self->close('hup'); }
788
789sub as_string {
790    my Perlbal::ClientHTTPBase $self = shift;
791
792    my $ret = $self->SUPER::as_string;
793    my $name = $self->{sock} ? getsockname($self->{sock}) : undef;
794    my $lport = $name ? (Socket::sockaddr_in($name))[0] : undef;
795    $ret .= ": localport=$lport" if $lport;
796    $ret .= "; reqs=$self->{requests}";
797    $ret .= "; $self->{state}";
798
799    my $hd = $self->{req_headers};
800    if (defined $hd) {
801        my $host = $hd->header('Host') || 'unknown';
802        $ret .= "; http://$host" . $hd->request_uri;
803    }
804
805    return $ret;
806}
807
8081;
809
810# Local Variables:
811# mode: perl
812# c-basic-indent: 4
813# indent-tabs-mode: nil
814# End:
Note: See TracBrowser for help on using the browser.