481 lines
16 KiB
Perl
481 lines
16 KiB
Perl
|
######################################################################
|
||
|
|
# Common HTTP functionality for ClientProxy and ClientHTTP
|
||
|
|
# possible states:
|
||
|
|
# reading_headers (initial state, then follows one of two paths)
|
||
|
|
# wait_backend, backend_req_sent, wait_res, xfer_res, draining_res
|
||
|
|
# wait_stat, wait_open, xfer_disk
|
||
|
|
# both paths can then go into persist_wait, which means they're waiting
|
||
|
|
# for another request from the user
|
||
|
|
######################################################################
|
||
|
|
|
||
|
|
package main;
|
||
|
|
|
||
|
|
# loading syscall.ph into package main in case some other module wants
|
||
|
|
# to use it (like Danga::Socket, or whoever else)
|
||
|
|
eval { require 'syscall.ph'; 1 } || eval { require 'sys/syscall.ph'; 1 };
|
||
|
|
|
||
|
|
package Perlbal::ClientHTTPBase;
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
use base "Perlbal::Socket";
|
||
|
|
use HTTP::Date ();
|
||
|
|
use fields ('service', # Perlbal::Service object
|
||
|
|
'replacement_uri', # URI to send instead of the one requested; this is used
|
||
|
|
# to instruct _serve_request to send an index file instead
|
||
|
|
# of trying to serve a directory and failing
|
||
|
|
'scratch', # extra storage; plugins can use it if they want
|
||
|
|
|
||
|
|
# reproxy support
|
||
|
|
'reproxy_file', # filename the backend told us to start opening
|
||
|
|
'reproxy_file_size', # size of file, once we stat() it
|
||
|
|
'reproxy_fh', # if needed, IO::Handle of fd
|
||
|
|
'reproxy_file_offset', # how much we've sent from the file.
|
||
|
|
|
||
|
|
'requests', # number of requests this object has performed for the user
|
||
|
|
);
|
||
|
|
|
||
|
|
use Errno qw( EPIPE ECONNRESET );
|
||
|
|
use POSIX ();
|
||
|
|
|
||
|
|
our $SYS_sendfile = &::SYS_sendfile;
|
||
|
|
|
||
|
|
# ghetto hard-coding. should let siteadmin define or something.
|
||
|
|
# maybe console/config command: AddMime <ext> <mime-type> (apache-style?)
|
||
|
|
our $MimeType = {qw(
|
||
|
|
css text/css
|
||
|
|
doc application/msword
|
||
|
|
gif image/gif
|
||
|
|
htm text/html
|
||
|
|
html text/html
|
||
|
|
jpg image/jpeg
|
||
|
|
js application/x-javascript
|
||
|
|
mp3 audio/mpeg
|
||
|
|
mpg video/mpeg
|
||
|
|
png image/png
|
||
|
|
tif image/tiff
|
||
|
|
tiff image/tiff
|
||
|
|
torrent application/x-bittorrent
|
||
|
|
txt text/plain
|
||
|
|
zip application/zip
|
||
|
|
)};
|
||
|
|
|
||
|
|
# ClientHTTPBase
|
||
|
|
sub new {
|
||
|
|
my ($class, $service, $sock) = @_;
|
||
|
|
|
||
|
|
my $self = $class;
|
||
|
|
$self = fields::new($class) unless ref $self;
|
||
|
|
$self->SUPER::new($sock); # init base fields
|
||
|
|
|
||
|
|
$self->{service} = $service;
|
||
|
|
$self->{replacement_uri} = undef;
|
||
|
|
$self->{headers_string} = '';
|
||
|
|
$self->state('reading_headers');
|
||
|
|
$self->{requests} = 0;
|
||
|
|
$self->{scratch} = {};
|
||
|
|
|
||
|
|
bless $self, ref $class || $class;
|
||
|
|
$self->watch_read(1);
|
||
|
|
return $self;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub close {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
|
||
|
|
# don't close twice
|
||
|
|
return if $self->{closed};
|
||
|
|
|
||
|
|
# close the file we were reproxying, if any
|
||
|
|
CORE::close($self->{reproxy_fh}) if $self->{reproxy_fh};
|
||
|
|
|
||
|
|
# now pass up the line
|
||
|
|
$self->SUPER::close(@_);
|
||
|
|
}
|
||
|
|
|
||
|
|
# given our request headers, determine if we should be sending
|
||
|
|
# keep-alive header information back to the client
|
||
|
|
sub setup_keepalive {
|
||
|
|
my Perlbal::ClientHTTPBase $self = $_[0];
|
||
|
|
|
||
|
|
# now get the headers we're using
|
||
|
|
my Perlbal::HTTPHeaders $hd = $_[1];
|
||
|
|
my Perlbal::HTTPHeaders $rqhd = $self->{req_headers};
|
||
|
|
|
||
|
|
# for now, we enforce outgoing HTTP 1.0
|
||
|
|
$hd->set_version("1.0");
|
||
|
|
|
||
|
|
# do keep alive if they sent content-length or it's a head request
|
||
|
|
my $do_keepalive = $self->{service}->{persist_client} &&
|
||
|
|
$rqhd->req_keep_alive($hd);
|
||
|
|
if ($do_keepalive) {
|
||
|
|
my $timeout = $self->max_idle_time;
|
||
|
|
$hd->header('Connection', 'keep-alive');
|
||
|
|
$hd->header('Keep-Alive', $timeout ? "timeout=$timeout, max=100" : undef);
|
||
|
|
} else {
|
||
|
|
$hd->header('Connection', 'close');
|
||
|
|
$hd->header('Keep-Alive', undef);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# called when we've finished writing everything to a client and we need
|
||
|
|
# to reset our state for another request. returns 1 to mean that we should
|
||
|
|
# support persistence, 0 means we're discarding this connection.
|
||
|
|
sub http_response_sent {
|
||
|
|
my Perlbal::ClientHTTPBase $self = $_[0];
|
||
|
|
|
||
|
|
# close if we're supposed to
|
||
|
|
if (!defined $self->{res_headers} ||
|
||
|
|
$self->{res_headers}->header('Connection') =~ m/\bclose\b/i ||
|
||
|
|
$self->{do_die}) {
|
||
|
|
# close if we have no response headers or they say to close
|
||
|
|
$self->close("no_keep_alive");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# now since we're doing persistence, uncork so the last packet goes.
|
||
|
|
# we will recork when we're processing a new request.
|
||
|
|
$self->tcp_cork(0);
|
||
|
|
|
||
|
|
# prepare!
|
||
|
|
$self->{replacement_uri} = undef;
|
||
|
|
$self->{headers_string} = '';
|
||
|
|
$self->{req_headers} = undef;
|
||
|
|
$self->{res_headers} = undef;
|
||
|
|
$self->{reproxy_fh} = undef;
|
||
|
|
$self->{reproxy_file} = undef;
|
||
|
|
$self->{reproxy_file_size} = 0;
|
||
|
|
$self->{reproxy_file_offset} = 0;
|
||
|
|
$self->{read_buf} = [];
|
||
|
|
$self->{read_ahead} = 0;
|
||
|
|
$self->{read_size} = 0;
|
||
|
|
$self->{scratch} = {};
|
||
|
|
|
||
|
|
# reset state
|
||
|
|
$self->state('persist_wait');
|
||
|
|
|
||
|
|
# NOTE: because we only speak 1.0 to clients they can't have
|
||
|
|
# pipeline in a read that we haven't read yet.
|
||
|
|
$self->watch_read(1);
|
||
|
|
$self->watch_write(0);
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
use Carp qw(cluck);
|
||
|
|
|
||
|
|
sub reproxy_fh {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
|
||
|
|
# setter
|
||
|
|
if (@_) {
|
||
|
|
my ($fh, $size) = @_;
|
||
|
|
$self->state('xfer_disk');
|
||
|
|
$self->{reproxy_fh} = $fh;
|
||
|
|
$self->{reproxy_file_offset} = 0;
|
||
|
|
$self->{reproxy_file_size} = $size;
|
||
|
|
# call hook that we're reproxying a file
|
||
|
|
return $fh if $self->{service}->run_hook("start_send_file", $self);
|
||
|
|
# turn on writes (the hook might not have wanted us to)
|
||
|
|
$self->watch_write(1);
|
||
|
|
return $fh;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $self->{reproxy_fh};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub event_write {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
|
||
|
|
# Any HTTP client is considered alive if it's writable
|
||
|
|
# if it's not writable for 30 seconds, we kill it.
|
||
|
|
# subclasses can decide what's appropriate for timeout.
|
||
|
|
$self->{alive_time} = time;
|
||
|
|
|
||
|
|
if ($self->{reproxy_fh}) {
|
||
|
|
my $to_send = $self->{reproxy_file_size} - $self->{reproxy_file_offset};
|
||
|
|
$self->tcp_cork(1) if $self->{reproxy_file_offset} == 0;
|
||
|
|
my $sent = syscall($SYS_sendfile,
|
||
|
|
$self->{fd},
|
||
|
|
fileno($self->{reproxy_fh}),
|
||
|
|
0, # NULL offset means kernel moves offset
|
||
|
|
$to_send);
|
||
|
|
print "REPROXY Sent: $sent\n" if Perlbal::DEBUG >= 2;
|
||
|
|
if ($sent < 0) {
|
||
|
|
return $self->close("epipe") if $! == EPIPE;
|
||
|
|
return $self->close("connreset") if $! == ECONNRESET;
|
||
|
|
print STDERR "Error w/ sendfile: $!\n";
|
||
|
|
$self->close('sendfile_error');
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$self->{reproxy_file_offset} += $sent;
|
||
|
|
|
||
|
|
if ($sent >= $to_send) {
|
||
|
|
# close the sendfile fd
|
||
|
|
CORE::close($self->{reproxy_fh});
|
||
|
|
|
||
|
|
$self->{reproxy_fh} = undef;
|
||
|
|
$self->http_response_sent;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($self->write(undef)) {
|
||
|
|
print "All writing done to $self\n" if Perlbal::DEBUG >= 2;
|
||
|
|
|
||
|
|
# we've written all data in the queue, so stop waiting for write
|
||
|
|
# notifications:
|
||
|
|
$self->watch_write(0);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# this gets called when a "web" service is serving a file locally.
|
||
|
|
sub _serve_request {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
my Perlbal::HTTPHeaders $hd = shift;
|
||
|
|
|
||
|
|
my $rm = $hd->request_method;
|
||
|
|
unless ($rm eq "HEAD" || $rm eq "GET") {
|
||
|
|
return $self->_simple_response(403, "Unimplemented method");
|
||
|
|
}
|
||
|
|
|
||
|
|
my $uri = _durl($self->{replacement_uri} || $hd->request_uri);
|
||
|
|
|
||
|
|
# don't allow directory traversal
|
||
|
|
if ($uri =~ /\.\./ || $uri !~ m!^/!) {
|
||
|
|
return $self->_simple_response(403, "Bogus URL");
|
||
|
|
}
|
||
|
|
|
||
|
|
my Perlbal::Service $svc = $self->{service};
|
||
|
|
|
||
|
|
# start_serve_request hook
|
||
|
|
return 1 if $self->{service}->run_hook('start_serve_request', $self, \$uri);
|
||
|
|
|
||
|
|
my $file = $svc->{docroot} . $uri;
|
||
|
|
|
||
|
|
# update state, since we're now waiting on stat
|
||
|
|
$self->state('wait_stat');
|
||
|
|
|
||
|
|
Perlbal::AIO::aio_stat($file, sub {
|
||
|
|
# client's gone anyway
|
||
|
|
return if $self->{closed};
|
||
|
|
return $self->_simple_response(404) unless -e _;
|
||
|
|
|
||
|
|
my $lastmod = HTTP::Date::time2str((stat(_))[9]);
|
||
|
|
my $not_mod = ($hd->header("If-Modified-Since") || "") eq $lastmod && -f _;
|
||
|
|
|
||
|
|
my $res;
|
||
|
|
my $not_satisfiable = 0;
|
||
|
|
my $size = -s _ if -f _;
|
||
|
|
|
||
|
|
my ($status, $range_start, $range_end) = $hd->range($size);
|
||
|
|
|
||
|
|
if ($not_mod) {
|
||
|
|
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(304);
|
||
|
|
} elsif ($status == 416) {
|
||
|
|
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(416);
|
||
|
|
$res->header("Content-Range", $size ? "*/$size" : "*");
|
||
|
|
$not_satisfiable = 1;
|
||
|
|
} elsif ($status == 206) {
|
||
|
|
# partial content
|
||
|
|
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(206);
|
||
|
|
} else {
|
||
|
|
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200);
|
||
|
|
}
|
||
|
|
|
||
|
|
# now set whether this is keep-alive or not
|
||
|
|
$res->header("Date", HTTP::Date::time2str());
|
||
|
|
$res->header("Server", "Perlbal");
|
||
|
|
$res->header("Last-Modified", $lastmod);
|
||
|
|
|
||
|
|
if (-f _) {
|
||
|
|
# advertise that we support byte range requests
|
||
|
|
$res->header("Accept-Ranges", "bytes");
|
||
|
|
|
||
|
|
unless ($not_mod && $not_satisfiable) {
|
||
|
|
my ($ext) = ($file =~ /\.(\w+)$/);
|
||
|
|
$res->header("Content-Type",
|
||
|
|
(defined $ext && exists $MimeType->{$ext}) ? $MimeType->{$ext} : "text/plain");
|
||
|
|
|
||
|
|
unless ($status == 206) {
|
||
|
|
$res->header("Content-Length", $size);
|
||
|
|
} else {
|
||
|
|
$res->header("Content-Range", "$range_start-$range_end/$size");
|
||
|
|
$res->header("Content-Length", $range_end-$range_start + 1);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# has to happen after content-length is set to work:
|
||
|
|
$self->setup_keepalive($res);
|
||
|
|
|
||
|
|
if ($rm eq "HEAD" || $not_mod || $not_satisfiable) {
|
||
|
|
# we can return already, since we know the size
|
||
|
|
$self->tcp_cork(1);
|
||
|
|
$self->state('xfer_resp');
|
||
|
|
$self->write($res->to_string_ref);
|
||
|
|
$self->write(sub { $self->http_response_sent; });
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# state update
|
||
|
|
$self->state('wait_open');
|
||
|
|
|
||
|
|
Perlbal::AIO::aio_open($file, 0, 0, sub {
|
||
|
|
my $rp_fh = shift;
|
||
|
|
|
||
|
|
# if client's gone, just close filehandle and abort
|
||
|
|
if ($self->{closed}) {
|
||
|
|
CORE::close($rp_fh) if $rp_fh;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# handle errors
|
||
|
|
if (! $rp_fh) {
|
||
|
|
# couldn't open the file we had already successfully stat'ed.
|
||
|
|
# FIXME: do 500 vs. 404 vs whatever based on $!
|
||
|
|
return $self->close('aio_open_failure');
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->state('xfer_disk');
|
||
|
|
$self->tcp_cork(1); # cork writes to self
|
||
|
|
$self->write($res->to_string_ref);
|
||
|
|
|
||
|
|
# seek if partial content
|
||
|
|
if ($status == 206) {
|
||
|
|
sysseek($rp_fh, $range_start, &POSIX::SEEK_SET);
|
||
|
|
$size = $range_end - $range_start + 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->reproxy_fh($rp_fh, $size);
|
||
|
|
});
|
||
|
|
|
||
|
|
} elsif (-d _) {
|
||
|
|
$self->try_index_files($hd, $res);
|
||
|
|
}
|
||
|
|
});
|
||
|
|
}
|
||
|
|
|
||
|
|
sub try_index_files {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
my ($hd, $res, $filepos) = @_;
|
||
|
|
|
||
|
|
# make sure this starts at 0 initially, and fail if it's past the end
|
||
|
|
$filepos ||= 0;
|
||
|
|
if ($filepos >= scalar(@{$self->{service}->{index_files} || []})) {
|
||
|
|
if ($self->{service}->{dirindexing}) {
|
||
|
|
# open the directory and create an index
|
||
|
|
my $body;
|
||
|
|
my $file = $self->{service}->{docroot} . '/' . $hd->request_uri;
|
||
|
|
|
||
|
|
$res->header("Content-Type", "text/html");
|
||
|
|
opendir(D, $file);
|
||
|
|
foreach my $de (sort readdir(D)) {
|
||
|
|
if (-d "$file/$de") {
|
||
|
|
$body .= "<b><a href='$de/'>$de</a></b><br />\n";
|
||
|
|
} else {
|
||
|
|
$body .= "<a href='$de'>$de</a><br />\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
closedir(D);
|
||
|
|
|
||
|
|
$res->header("Content-Length", length($body));
|
||
|
|
$self->setup_keepalive($res);
|
||
|
|
|
||
|
|
$self->state('xfer_resp');
|
||
|
|
$self->tcp_cork(1); # cork writes to self
|
||
|
|
$self->write($res->to_string_ref);
|
||
|
|
$self->write(\$body);
|
||
|
|
$self->write(sub { $self->http_response_sent; });
|
||
|
|
} else {
|
||
|
|
# just inform them that listing is disabled
|
||
|
|
$self->_simple_response(200, "Directory listing disabled")
|
||
|
|
}
|
||
|
|
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# construct the file path we need to check
|
||
|
|
my $file = $self->{service}->{index_files}->[$filepos];
|
||
|
|
my $fullpath = $self->{service}->{docroot} . '/' . $hd->request_uri . '/' . $file;
|
||
|
|
|
||
|
|
# now see if it exists
|
||
|
|
Perlbal::AIO::aio_stat($fullpath, sub {
|
||
|
|
return if $self->{closed};
|
||
|
|
return $self->try_index_files($hd, $res, $filepos + 1) unless -f _;
|
||
|
|
|
||
|
|
# at this point the file exists, so we just want to serve it
|
||
|
|
$self->{replacement_uri} = $hd->request_uri . '/' . $file;
|
||
|
|
return $self->_serve_request($hd);
|
||
|
|
});
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _simple_response {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
my ($code, $msg) = @_; # or bodyref
|
||
|
|
|
||
|
|
my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response($code);
|
||
|
|
$res->header("Content-Type", "text/html");
|
||
|
|
|
||
|
|
my $body;
|
||
|
|
unless ($code == 204) {
|
||
|
|
my $en = $res->http_code_english;
|
||
|
|
$body = "<h1>$code" . ($en ? " - $en" : "") . "</h1>\n";
|
||
|
|
$body .= $msg if $msg;
|
||
|
|
$res->header('Content-Length', length($body));
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->setup_keepalive($res);
|
||
|
|
|
||
|
|
$self->state('xfer_resp');
|
||
|
|
$self->tcp_cork(1); # cork writes to self
|
||
|
|
$self->write($res->to_string_ref);
|
||
|
|
if (defined $body) {
|
||
|
|
unless ($self->{req_headers} && $self->{req_headers}->request_method eq 'HEAD') {
|
||
|
|
# don't write body for head requests
|
||
|
|
$self->write(\$body);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$self->write(sub { $self->http_response_sent; });
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# FIXME: let this be configurable?
|
||
|
|
sub max_idle_time { 30; }
|
||
|
|
|
||
|
|
sub event_err { my $self = shift; $self->close('error'); }
|
||
|
|
sub event_hup { my $self = shift; $self->close('hup'); }
|
||
|
|
|
||
|
|
sub as_string {
|
||
|
|
my Perlbal::ClientHTTPBase $self = shift;
|
||
|
|
|
||
|
|
my $ret = $self->SUPER::as_string;
|
||
|
|
my $name = $self->{sock} ? getsockname($self->{sock}) : undef;
|
||
|
|
my $lport = $name ? (Socket::sockaddr_in($name))[0] : undef;
|
||
|
|
$ret .= ": localport=$lport" if $lport;
|
||
|
|
$ret .= "; reqs=$self->{requests}";
|
||
|
|
$ret .= "; $self->{state}";
|
||
|
|
|
||
|
|
my $hd = $self->{req_headers};
|
||
|
|
if (defined $hd) {
|
||
|
|
my $host = $hd->header('Host') || 'unknown';
|
||
|
|
$ret .= "; http://$host" . $hd->request_uri;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _durl {
|
||
|
|
my ($a) = @_;
|
||
|
|
$a =~ tr/+/ /;
|
||
|
|
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
|
||
|
|
return $a;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|
||
|
|
|
||
|
|
|
||
|
|
# Local Variables:
|
||
|
|
# mode: perl
|
||
|
|
# c-basic-indent: 4
|
||
|
|
# indent-tabs-mode: nil
|
||
|
|
# End:
|