zlax/ljr
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

init

Browse Source
This commit is contained in:
ivan
2019-02-06 00:49:12 +03:00
commit 8dbb1bb605
4796 changed files with 506072 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

101
wcmtools/perlbal/lib/Perlbal/AIO.pm Executable file
View File

@@ -0,0 +1,101 @@
package Perlbal::AIO;
use POSIX qw();
sub aio_stat {
my ($file, $cb) = @_;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_stat($file, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_stat($file, $cb);
} else {
stat($file);
$cb->();
}
}
sub _fh_of_fd_mode {
my ($fd, $mode) = @_;
return undef unless defined $fd && $fd >= 0;
#TODO: use the write MODE for the given $mode;
my $fh = IO::Handle->new_from_fd($fd, 'r+');
my $num = fileno($fh);
return $fh;
}
sub aio_open {
my ($file, $flags, $mode, $cb) = @_;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_open($file, $flags, $mode, sub {
my $fd = shift;
my $fh = _fh_of_fd_mode($fd, $mode);
$cb->($fh);
});
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_open($file, $flags, $mode, $cb);
} else {
my $fh;
my $rv = sysopen($fh, $file, $flags, $mode);
$cb->($rv ? $fh : undef);
}
}
sub aio_unlink {
my ($file, $cb) = @_;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_unlink($file, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_unlink($file, $cb);
} else {
my $rv = unlink($file);
$rv = $rv ? 0 : -1;
$cb->($rv);
}
}
sub aio_write {
# 0 1 2 3(data) 4
my ($fh, $offset, $length, undef, $cb) = @_;
return no_fh($cb) unless $fh;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_write($fh, $offset, $length, $_[3], 0, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_write($fh, $offset, $length, $_[3], 0, $cb);
} else {
my $rv = syswrite($fh, $_[3], $length, $offset);
$cb->($rv);
}
}
sub aio_read {
# 0 1 2 3(data) 4
my ($fh, $offset, $length, undef, $cb) = @_;
return no_fh($cb) unless $fh;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_read($fh, $offset, $length, $_[3], 0, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_read($fh, $offset, $length, $_[3], 0, $cb);
} else {
my $rv = sysread($fh, $_[3], $length, $offset);
$cb->($rv);
}
}
sub no_fh {
my $cb = shift;
my $i = 1;
my $stack_trace = "";
while (my ($pkg, $filename, $line, $subroutine, $hasargs,
$wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i++)) {
$stack_trace .= " at $filename:$line $subroutine\n";
}
Perlbal::log("crit", "Undef \$fh: $stack_trace");
$cb->(undef);
return undef;
}
1;

570
wcmtools/perlbal/lib/Perlbal/BackendHTTP.pm Executable file
View File

@@ -0,0 +1,570 @@
######################################################################
# HTTP connection to backend node
# possible states: connecting, bored, sending_req, wait_res, xfer_res
######################################################################
package Perlbal::BackendHTTP;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields ('client', # Perlbal::ClientProxy connection, or undef
'service', # Perlbal::Service
'pool', # Perlbal::Pool; whatever pool we spawned from
'ip', # IP scalar
'port', # port scalar
'ipport', # "$ip:$port"
'reportto', # object; must implement reporter interface
'has_attention', # has been accepted by a webserver and
# we know for sure we're not just talking
# to the TCP stack
'waiting_options', # if true, we're waiting for an OPTIONS *
# response to determine when we have attention
'disconnect_at', # time this connection will be disconnected,
# if it's kept-alive and backend told us.
# otherwise undef for unknown.
# The following only apply when the backend server sends
# a content-length header
'content_length', # length of document being transferred
'content_length_remain', # bytes remaining to be read
'use_count', # number of requests this backend's been used for
'generation', # int; counts what generation we were spawned in
);
use Socket qw(PF_INET IPPROTO_TCP SOCK_STREAM);
use Perlbal::ClientProxy;
# if this is made too big, (say, 128k), then perl does malloc instead
# of using its slab cache.
use constant BACKEND_READ_SIZE => 61449; # 60k, to fit in a 64k slab
# keys set here when an endpoint is found to not support persistent
# connections and/or the OPTIONS method
our %NoVerify; # { "ip:port" => next-verify-time }
our %NodeStats; # { "ip:port" => { ... } }; keep statistics about nodes
# constructor for a backend connection takes a service (pool) that it's
# for, and uses that service to get its backend IP/port, as well as the
# client that will be using this backend connection. final parameter is
# an options hashref that contains some options:
# reportto => object obeying reportto interface
sub new {
my ($class, $svc, $ip, $port, $opts) = @_;
$opts ||= {};
my $sock;
socket $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP;
unless ($sock && defined fileno($sock)) {
Perlbal::log('crit', "Error creating socket: $!");
return undef;
}
IO::Handle::blocking($sock, 0);
connect $sock, Socket::sockaddr_in($port, Socket::inet_aton($ip));
my $self = fields::new($class);
$self->SUPER::new($sock);
Perlbal::objctor($self);
$self->{ip} = $ip; # backend IP
$self->{port} = $port; # backend port
$self->{ipport} = "$ip:$port"; # often used as key
$self->{service} = $svc; # the service we're serving for
$self->{pool} = $opts->{pool}; # what pool we came from.
$self->{reportto} = $opts->{reportto} || $svc; # reportto if specified
$self->state("connecting");
# mark another connection to this ip:port
$NodeStats{$self->{ipport}}->{attempts}++;
$NodeStats{$self->{ipport}}->{lastattempt} = $self->{create_time};
# setup callback in case we get stuck in connecting land
Perlbal::Socket::register_callback(15, sub {
if ($self->state eq 'connecting' || $self->state eq 'verifying_backend') {
# shouldn't still be connecting/verifying ~15 seconds after create
$self->close('callback_timeout');
}
return 0;
});
# for header reading:
$self->{req_headers} = undef;
$self->{res_headers} = undef; # defined w/ headers object once all headers in
$self->{headers_string} = ""; # blank to start
$self->{read_buf} = []; # scalar refs of bufs read from client
$self->{read_ahead} = 0; # bytes sitting in read_buf
$self->{read_size} = 0; # total bytes read from client
$self->{client} = undef; # Perlbal::ClientProxy object, initially empty
# until we ask our service for one
$self->{has_attention} = 0;
$self->{use_count} = 0;
$self->{generation} = $opts->{generation};
bless $self, ref $class || $class;
$self->watch_write(1);
return $self;
}
sub close {
my Perlbal::BackendHTTP $self = shift;
# don't close twice
return if $self->{closed};
# this closes the socket and sets our closed flag
$self->SUPER::close(@_);
# tell our client that we're gone
if (my $client = $self->{client}) {
$client->backend(undef);
$self->{client} = undef;
}
# tell our owner that we're gone
if (my $reportto = $self->{reportto}) {
$reportto->note_backend_close($self);
$self->{reportto} = undef;
}
}
# return our defined generation counter with no parameter,
# or set our generation if given a parameter
sub generation {
my Perlbal::BackendHTTP $self = $_[0];
return $self->{generation} unless $_[1];
return $self->{generation} = $_[1];
}
# return what ip and port combination we're using
sub ipport {
my Perlbal::BackendHTTP $self = $_[0];
return $self->{ipport};
}
# called by service when it's got a client for us, or by ourselves
# when we asked for a client.
# returns true if client assignment was accepted.
sub assign_client {
my Perlbal::BackendHTTP $self = shift;
my Perlbal::ClientProxy $client = shift;
return 0 if $self->{client};
# set our client, and the client's backend to us
$self->{service}->mark_node_used($self->{ipport});
$self->{client} = $client;
$self->state("sending_req");
$self->{client}->backend($self);
my Perlbal::HTTPHeaders $hds = $client->{req_headers}->clone;
$self->{req_headers} = $hds;
# Use HTTP/1.0 to backend (FIXME: use 1.1 and support chunking)
$hds->set_version("1.0");
my $persist = $self->{service}{persist_backend};
$hds->header("Connection", $persist ? "keep-alive" : "close");
$hds->header("X-Proxy-Capabilities", "reproxy-file");
# decide whether we trust the upstream or not
my $trust = $self->{service}->{always_trusted}; # set to default auto-trust level
if ($self->{service} && $self->{service}->{trusted_upstreams}) {
$trust = 1
if $self->{service}->{trusted_upstreams}->match($client->peer_ip_string);
}
# if we're not going to trust the upstream, reset these for security reasons
unless ($trust) {
$hds->header("X-Forwarded-For", $client->peer_ip_string);
$hds->header("X-Host", undef);
$hds->header("X-Forwarded-Host", undef);
}
$self->tcp_cork(1);
$client->state('backend_req_sent');
$self->{content_length} = undef;
$self->{content_length_remain} = undef;
# run hooks
return 1 if $self->{service}->run_hook('backend_client_assigned', $self);
# now cleanup the headers before we send to the backend
$self->{service}->munge_headers($hds) if $self->{service};
$self->write($hds->to_string_ref);
$self->write(sub {
$self->tcp_cork(0);
if (my $client = $self->{client}) {
# start waiting on a reply
$self->watch_read(1);
$self->state("wait_res");
$client->state('wait_res');
# make the client push its overflow reads (request body)
# to the backend
$client->drain_read_buf_to($self);
# and start watching for more reads
$client->watch_read(1);
}
});
return 1;
}
# Backend
sub event_write {
my Perlbal::BackendHTTP $self = shift;
print "Backend $self is writeable!\n" if Perlbal::DEBUG >= 2;
my $now = time();
delete $NoVerify{$self->{ipport}} if
defined $NoVerify{$self->{ipport}} &&
$NoVerify{$self->{ipport}} < $now;
if (! $self->{client} && $self->{state} eq "connecting") {
# not interested in writes again until something else is
$self->watch_write(0);
$NodeStats{$self->{ipport}}->{connects}++;
$NodeStats{$self->{ipport}}->{lastconnect} = $now;
if (defined $self->{service} && $self->{service}->{verify_backend} &&
!$self->{has_attention} && !defined $NoVerify{$self->{ipport}}) {
# the backend should be able to answer this incredibly quickly.
$self->write("OPTIONS * HTTP/1.0\r\nConnection: keep-alive\r\n\r\n");
$self->watch_read(1);
$self->{waiting_options} = 1;
$self->{content_length_remain} = undef;
$self->state("verifying_backend");
} else {
# register our boredom (readiness for a client/request)
$self->state("bored");
$self->{reportto}->register_boredom($self);
}
return;
}
my $done = $self->write(undef);
$self->watch_write(0) if $done;
}
sub verify_failure {
my Perlbal::BackendHTTP $self = shift;
$NoVerify{$self->{ipport}} = time() + 60;
$self->{reportto}->note_bad_backend_connect($self);
$self->close('no_keep_alive');
return;
}
# Backend
sub event_read {
my Perlbal::BackendHTTP $self = shift;
print "Backend $self is readable!\n" if Perlbal::DEBUG >= 2;
if ($self->{waiting_options}) {
if ($self->{content_length_remain}) {
# the HTTP/1.1 spec says OPTIONS responses can have content-lengths,
# but the meaning of the response is reserved for a future spec.
# this just gobbles it up for.
my $bref = $self->read(BACKEND_READ_SIZE);
return $self->verify_failure unless defined $bref;
$self->{content_length_remain} -= length($$bref);
} elsif (my $hd = $self->read_response_headers) {
# see if we have keep alive support
return $self->verify_failure unless $hd->res_keep_alive($self->{req_headers});
$self->{content_length_remain} = $hd->header("Content-Length");
}
# if we've got the option response and read any response data
# if present:
if ($self->{res_headers} && ! $self->{content_length_remain}) {
# other setup to mark being done with options checking
$self->{waiting_options} = 0;
$self->{has_attention} = 1;
$NodeStats{$self->{ipport}}->{verifies}++;
$self->next_request(1); # initial
}
return;
}
my Perlbal::ClientProxy $client = $self->{client};
# with persistent connections, sometimes we have a backend and
# no client, and backend becomes readable, either to signal
# to use the end of the stream, or because a bad request error,
# which I can't totally understand. in any case, we have
# no client so all we can do is close this backend.
return $self->close('read_with_no_client') unless $client;
unless ($self->{res_headers}) {
if (my $hd = $self->read_response_headers) {
# note we got this response code
my $ref = ($NodeStats{$self->{ipport}}->{responsecodes} ||= []);
push @$ref, $hd->response_code;
if (scalar(@$ref) > 500) {
shift @$ref;
}
# call service response received function
return if $self->{reportto}->backend_response_received($self);
# standard handling
$self->state("xfer_res");
$client->state("xfer_res");
$self->{has_attention} = 1;
# RFC 2616, Sec 4.4: Messages MUST NOT include both a
# Content-Length header field and a non-identity
# transfer-coding. If the message does include a non-
# identity transfer-coding, the Content-Length MUST be
# ignored.
my $te = $hd->header("Transfer-Encoding");
if ($te && $te !~ /\bidentity\b/i) {
$hd->header("Content-Length", undef);
}
my Perlbal::HTTPHeaders $rqhd = $self->{req_headers};
# setup our content length so we know how much data to expect, in general
# we want the content-length from the response, but if this was a head request
# we know it's a 0 length message the client wants
if ($rqhd->request_method eq 'HEAD') {
$self->{content_length} = 0;
} else {
$self->{content_length} = $hd->content_length;
}
$self->{content_length_remain} = $self->{content_length} || 0;
if (my $rep = $hd->header('X-REPROXY-FILE')) {
# make the client begin the async IO while we move on
$client->start_reproxy_file($rep, $hd);
$self->next_request;
return;
} elsif (my $urls = $hd->header('X-REPROXY-URL')) {
$client->start_reproxy_uri($self->{res_headers}, $urls);
$self->next_request;
return;
} else {
my $res_source = $client->{primary_res_hdrs} || $hd;
my $thd = $client->{res_headers} = $res_source->clone;
# setup_keepalive will set Connection: and Keep-Alive: headers for us
# as well as setup our HTTP version appropriately
$client->setup_keepalive($thd);
# if we had an alternate primary response header, make sure
# we send the real content-length (from the reproxied URL)
# and not the one the first server gave us
if ($client->{primary_res_hdrs}) {
$thd->header('Content-Length', $hd->header('Content-Length'));
$thd->header('X-REPROXY-FILE', undef);
$thd->header('X-REPROXY-URL', undef);
$thd->header('X-REPROXY-EXPECTED-SIZE', undef);
}
$client->write($thd->to_string_ref);
# if we over-read anything from backend (most likely)
# then decrement it from our count of bytes we need to read
if (defined $self->{content_length}) {
$self->{content_length_remain} -= $self->{read_ahead};
}
$self->drain_read_buf_to($client);
if (defined $self->{content_length} && ! $self->{content_length_remain}) {
# order important: next_request detaches us from client, so
# $client->close can't kill us
$self->next_request;
$client->write(sub { $client->backend_finished; });
}
}
}
return;
}
# if our client's behind more than the max limit, stop buffering
my $buf_size = defined $self->{service} ? $client->{service}->{buffer_size} : $client->{service}->{buffer_size_reproxy_url};
if ($client->{write_buf_size} > $buf_size) {
$self->watch_read(0);
return;
}
my $bref = $self->read(BACKEND_READ_SIZE);
if (defined $bref) {
$client->write($bref);
# HTTP/1.0 keep-alive support to backend. we just count bytes
# until we hit the end, then we know we can send another
# request on this connection
if ($self->{content_length}) {
$self->{content_length_remain} -= length($$bref);
if (! $self->{content_length_remain}) {
# order important: next_request detaches us from client, so
# $client->close can't kill us
$self->next_request;
$client->write(sub { $client->backend_finished; });
}
}
return;
} else {
# backend closed
print "Backend $self is done; closing...\n" if Perlbal::DEBUG >= 1;
$client->backend(undef); # disconnect ourselves from it
$self->{client} = undef; # .. and it from us
$self->close('backend_disconnect'); # close ourselves
$client->write(sub { $client->backend_finished; });
return;
}
}
# if $initial is on, then don't increment use count
sub next_request {
my Perlbal::BackendHTTP $self = $_[0];
my $initial = $_[1];
# don't allow this if we're closed
return if $self->{closed};
# set alive_time so reproxy can intelligently reuse this backend
my $now = time();
$self->{alive_time} = $now;
$NodeStats{$self->{ipport}}->{requests}++ unless $initial;
$NodeStats{$self->{ipport}}->{lastresponse} = $now;
my $hd = $self->{res_headers}; # response headers
# verify that we have keep-alive support
return $self->close('next_request_no_persist')
unless $hd->res_keep_alive($self->{req_headers});
# and now see if we should closed based on the pool we're from
return $self->close('pool_requested_closure')
if $self->{pool} && ! $self->{pool}->backend_should_live($self);
# we've been used
$self->{use_count}++ unless $initial;
# service specific
if (my Perlbal::Service $svc = $self->{service}) {
# keep track of how many times we've been used, and don't
# keep using this connection more times than the service
# is configured for.
if ($svc->{max_backend_uses} && ($self->{use_count} > $svc->{max_backend_uses})) {
return $self->close('exceeded_max_uses');
}
}
# if backend told us, keep track of when the backend
# says it's going to boot us, so we don't use it within
# a few seconds of that time
if (($hd->header("Keep-Alive") || '') =~ /\btimeout=(\d+)/i) {
$self->{disconnect_at} = $now + $1;
} else {
$self->{disconnect_at} = undef;
}
$self->{client} = undef;
$self->state("bored");
$self->watch_write(0);
$self->{req_headers} = undef;
$self->{res_headers} = undef;
$self->{headers_string} = "";
$self->{req_headers} = undef;
$self->{read_size} = 0;
$self->{content_length_remain} = undef;
$self->{content_length} = undef;
$self->{reportto}->register_boredom($self);
return;
}
# Backend: bad connection to backend
sub event_err {
my Perlbal::BackendHTTP $self = shift;
# FIXME: we get this after backend is done reading and we disconnect,
# hence the misc checks below for $self->{client}.
print "BACKEND event_err\n" if
Perlbal::DEBUG >= 2;
if ($self->{client}) {
# request already sent to backend, then an error occurred.
# we don't want to duplicate POST requests, so for now
# just fail
# TODO: if just a GET request, retry?
$self->{client}->close('backend_error');
$self->close('error');
return;
}
if ($self->{state} eq "connecting" ||
$self->{state} eq "verifying_backend") {
# then tell the service manager that this connection
# failed, so it can spawn a new one and note the dead host
$self->{reportto}->note_bad_backend_connect($self, 1);
}
# close ourselves first
$self->close("error");
}
# Backend
sub event_hup {
my Perlbal::BackendHTTP $self = shift;
print "HANGUP for $self\n" if Perlbal::DEBUG;
$self->close("after_hup");
}
sub as_string {
my Perlbal::BackendHTTP $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;
if (my Perlbal::ClientProxy $cp = $self->{client}) {
$ret .= "; client=$cp->{fd}";
}
$ret .= "; uses=$self->{use_count}; $self->{state}";
if (defined $self->{service} && $self->{service}->{verify_backend}) {
$ret .= "; has_attention=";
$ret .= $self->{has_attention} ? 'yes' : 'no';
}
return $ret;
}
sub die_gracefully {
# see if we need to die
my Perlbal::BackendHTTP $self = shift;
$self->close('graceful_death') if $self->state eq 'bored';
}
sub DESTROY {
Perlbal::objdtor($_[0]);
$_[0]->SUPER::DESTROY;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

339
wcmtools/perlbal/lib/Perlbal/ClientHTTP.pm Executable file
View File

@@ -0,0 +1,339 @@
######################################################################
# HTTP Connection from a reverse proxy client. GET/HEAD only.
# most functionality is implemented in the base class.
######################################################################
package Perlbal::ClientHTTP;
use strict;
use warnings;
use base "Perlbal::ClientHTTPBase";
use fields ('put_in_progress', # 1 when we're currently waiting for an async job to return
'put_fh', # file handle to use for writing data
'put_pos', # file offset to write next data at
'content_length', # length of document being transferred
'content_length_remain', # bytes remaining to be read
);
use HTTP::Date ();
use File::Path;
use Errno qw( EPIPE );
use POSIX qw( O_CREAT O_TRUNC O_WRONLY O_RDONLY ENOENT );
# class list of directories we know exist
our (%VerifiedDirs);
sub new {
my $class = shift;
my $self = fields::new($class);
$self->SUPER::new(@_);
$self->{put_in_progress} = 0;
$self->{put_fh} = undef;
$self->{put_pos} = 0;
return $self;
}
sub close {
my Perlbal::ClientHTTP $self = shift;
# don't close twice
return if $self->{closed};
$self->{put_fh} = undef;
$self->SUPER::close(@_);
}
sub send_response {
my Perlbal::ClientHTTP $self = shift;
$self->watch_read(0);
$self->watch_write(1);
return $self->_simple_response(@_);
}
sub event_read {
my Perlbal::ClientHTTP $self = shift;
# see if we have headers?
if ($self->{req_headers}) {
if ($self->{req_headers}->request_method eq 'PUT') {
# read in data and shove it on the read buffer
if (defined (my $dataref = $self->read($self->{content_length_remain}))) {
# got some data
$self->{read_buf} .= $$dataref;
my $clen = length($$dataref);
$self->{read_size} += $clen;
$self->{content_length_remain} -= $clen;
# handle put if we should
$self->handle_put if $self->{read_size} >= 8192; # arbitrary
# now, if we've filled the content of this put, we're done
unless ($self->{content_length_remain}) {
$self->watch_read(0);
$self->handle_put;
}
} else {
# undefined read, user closed on us
$self->close('remote_closure');
}
} else {
# since we have headers and we're not doing any special
# handling above, let's just disable read notification, because
# we won't do anything with the data
$self->watch_read(0);
}
return;
}
# try and get the headers, if they're all here
my $hd = $self->read_request_headers;
return unless $hd;
# fully formed request received
$self->{requests}++;
# notify that we're about to serve
return if $self->{service}->run_hook('start_web_request', $self);
# see what method it is?
if ($hd->request_method eq 'GET' || $hd->request_method eq 'HEAD') {
# and once we have it, start serving
$self->watch_read(0);
return $self->_serve_request($hd);
} elsif ($self->{service}->{enable_put} && $hd->request_method eq 'PUT') {
# they want to put something, so let's setup and wait for more reads
my $clen = $hd->header('Content-length') + 0;
# return a 400 (bad request) if we got no content length or if it's
# bigger than any specified max put size
return $self->send_response(400, "Content-length of $clen is invalid.")
if !$clen ||
($self->{service}->{max_put_size} &&
$clen > $self->{service}->{max_put_size});
# if we have some data already from a header over-read, handle it by
# flattening it down to a single string as opposed to an array of stuff
if (defined $self->{read_size} && $self->{read_size} > 0) {
my $data = '';
foreach my $rdata (@{$self->{read_buf}}) {
$data .= ref $rdata ? $$rdata : $rdata;
}
$self->{read_buf} = $data;
$self->{content_length} = $clen;
$self->{content_length_remain} = $clen - $self->{read_size};
} else {
# setup to read the file
$self->{read_buf} = '';
$self->{content_length} = $self->{content_length_remain} = $clen;
}
# setup the directory asynchronously
$self->setup_put;
return;
} elsif ($self->{service}->{enable_delete} && $hd->request_method eq 'DELETE') {
# delete a file
$self->watch_read(0);
return $self->setup_delete;
}
# else, bad request
return $self->send_response(400);
}
# called when we're requested to do a delete
sub setup_delete {
my Perlbal::ClientHTTP $self = shift;
# error in filename? (any .. is an error)
my $uri = $self->{req_headers}->request_uri;
return $self->send_response(400, 'Invalid filename')
if $uri =~ /\.\./;
# now we want to get the URI
if ($uri =~ m!^(?:/[\w\-\.]+)+$!) {
# now attempt the unlink
Perlbal::AIO::aio_unlink($self->{service}->{docroot} . '/' . $uri, sub {
my $err = shift;
if ($err == 0 && !$!) {
# delete was successful
return $self->send_response(204);
} elsif ($! == ENOENT) {
# no such file
return $self->send_response(404);
} else {
# failure...
return $self->send_response(400, "$!");
}
});
} else {
# bad URI, don't accept the delete
return $self->send_response(400, 'Invalid filename');
}
}
# called when we've got headers and are about to start a put
sub setup_put {
my Perlbal::ClientHTTP $self = shift;
return if $self->{service}->run_hook('setup_put', $self);
return if $self->{put_fh};
# error in filename? (any .. is an error)
my $uri = $self->{req_headers}->request_uri;
return $self->send_response(400, 'Invalid filename')
if $uri =~ /\.\./;
# now we want to get the URI
if ($uri =~ m!^((?:/[\w\-\.]+)*)/([\w\-\.]+)$!) {
# sanitize uri into path and file into a disk path and filename
my ($path, $filename) = ($1 || '', $2);
# verify minput if necessary
if ($self->{service}->{min_put_directory}) {
my @elems = grep { defined $_ && length $_ } split '/', $path;
return $self->send_response(400, 'Does not meet minimum directory requirement')
unless scalar(@elems) >= $self->{service}->{min_put_directory};
my $minput = '/' . join('/', splice(@elems, 0, $self->{service}->{min_put_directory}));
my $path = '/' . join('/', @elems);
return unless $self->verify_put($minput, $path, $filename);
}
# now we want to open this directory
my $lpath = $self->{service}->{docroot} . '/' . $path;
return $self->attempt_open($lpath, $filename);
} else {
# bad URI, don't accept the put
return $self->send_response(400, 'Invalid filename');
}
}
# verify that a minimum put directory exists
# return value: 1 means the directory is okay, continue
# 0 means we must verify the directory, stop processing
sub verify_put {
my Perlbal::ClientHTTP $self = shift;
my ($minput, $extrapath, $filename) = @_;
my $mindir = $self->{service}->{docroot} . '/' . $minput;
return 1 if $VerifiedDirs{$mindir};
$self->{put_in_progress} = 1;
Perlbal::AIO::aio_open($mindir, O_RDONLY, 0755, sub {
my $fh = shift;
$self->{put_in_progress} = 0;
# if error return failure
return $self->send_response(404, "Base directory does not exist") unless $fh;
CORE::close($fh);
# mindir existed, mark it as so and start the open for the rest of the path
$VerifiedDirs{$mindir} = 1;
return $self->attempt_open($mindir . $extrapath, $filename);
});
return 0;
}
# attempt to open a file
sub attempt_open {
my Perlbal::ClientHTTP $self = shift;
my ($path, $file) = @_;
$self->{put_in_progress} = 1;
Perlbal::AIO::aio_open("$path/$file", O_CREAT | O_TRUNC | O_WRONLY, 0644, sub {
# get the fd
my $fh = shift;
# verify file was opened
$self->{put_in_progress} = 0;
if (! $fh) {
if ($! == ENOENT) {
# directory doesn't exist, so let's manually create it
eval { File::Path::mkpath($path, 0, 0755); };
return $self->system_error("Unable to create directory", "path = $path, file = $file") if $@;
# should be created, call self recursively to try
return $self->attempt_open($path, $file);
} else {
return $self->system_error("Internal error", "error = $!, path = $path, file = $file");
}
}
$self->{put_fh} = $fh;
$self->{put_pos} = 0;
$self->handle_put;
});
}
# method that sends a 500 to the user but logs it and any extra information
# we have about the error in question
sub system_error {
my Perlbal::ClientHTTP $self = shift;
my ($msg, $info) = @_;
# log to syslog
Perlbal::log('warning', "system error: $msg ($info)");
# and return a 500
return $self->send_response(500, $msg);
}
# called when we've got some put data to write out
sub handle_put {
my Perlbal::ClientHTTP $self = shift;
return if $self->{service}->run_hook('handle_put', $self);
return if $self->{put_in_progress};
return unless $self->{put_fh};
return unless $self->{read_size};
# dig out data to write
my ($data, $count) = ($self->{read_buf}, $self->{read_size});
($self->{read_buf}, $self->{read_size}) = ('', 0);
# okay, file is open, write some data
$self->{put_in_progress} = 1;
Perlbal::AIO::aio_write($self->{put_fh}, $self->{put_pos}, $count, $data, sub {
return if $self->{closed};
# see how many bytes written
my $bytes = shift() + 0;
$self->{put_pos} += $bytes;
$self->{put_in_progress} = 0;
# now recursively call ourselves?
if ($self->{read_size}) {
$self->handle_put;
} else {
# we done putting this file?
unless ($self->{content_length_remain}) {
# close it
# FIXME this should be done through AIO
if ($self->{put_fh} && CORE::close($self->{put_fh})) {
$self->{put_fh} = undef;
return $self->send_response(200);
} else {
return $self->system_error("Error saving file", "error in close: $!");
}
}
}
});
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

480
wcmtools/perlbal/lib/Perlbal/ClientHTTPBase.pm Executable file
View File

@@ -0,0 +1,480 @@
######################################################################
# 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:

139
wcmtools/perlbal/lib/Perlbal/ClientManage.pm Executable file
View File

@@ -0,0 +1,139 @@
######################################################################
# Management connection from a client
######################################################################
package Perlbal::ClientManage;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields ('service',
'buf',
'is_http', # bool: is an HTTP request?
'verbose', # bool: on/off if we should be verbose for management commands
);
# ClientManage
sub new {
my ($class, $service, $sock) = @_;
my $self = $class->SUPER::new($sock);
$self->{service} = $service;
$self->{buf} = ""; # what we've read so far, not forming a complete line
$self->{verbose} = 1;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
# ClientManage
sub event_read {
my Perlbal::ClientManage $self = shift;
my $bref;
unless ($self->{is_http}) {
$bref = $self->read(1024);
return $self->close() unless defined $bref;
$self->{buf} .= $$bref;
if ($self->{buf} =~ /^(?:HEAD|GET|POST) /) {
$self->{is_http} = 1;
$self->{headers_string} .= $$bref;
}
}
if ($self->{is_http}) {
my $hd = $self->read_request_headers;
return unless $hd;
$self->handle_http();
return;
}
while ($self->{buf} =~ s/^(.+?)\r?\n//) {
my $line = $1;
# enable user to turn verbose on and off for our connection
if ($line =~ /^verbose (on|off)$/i) {
$self->{verbose} = (lc $1 eq 'on' ? 1 : 0);
$self->write("OK\r\n") if $self->{verbose};
next;
}
if ($line =~ /^quit/) {
$self->close('user_requested_quit');
return;
}
Perlbal::run_manage_command($line, sub {
$self->write(join("\r\n", map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_) . "\r\n");
}, $self->{verbose});
}
}
# ClientManage
sub event_err { my $self = shift; $self->close; }
sub event_hup { my $self = shift; $self->close; }
# HTTP management support
sub handle_http {
my Perlbal::ClientManage $self = shift;
my $uri = $self->{req_headers}->request_uri;
my $body;
my $code = "200 OK";
my $prebox = sub {
my $cmd = shift;
my $alt = shift;
$body .= "<pre><div style='margin-bottom: 5px; background: #ddd'><b>$cmd</b></div>";
Perlbal::run_manage_command($cmd, sub {
my $line = $_[0] || "";
$alt->(\$line) if $alt;
$body .= "$line\n";
});
$body .= "</pre>\n";
};
if ($uri eq "/") {
$body .= "<h1>perlbal management interface</h1><ul>";
$body .= "<li><a href='/socks'>Sockets</a></li>";
$body .= "<li><a href='/obj'>Perl Objects in use</a></li>";
$body .= "<li>Service Details<ul>";
foreach my $sname (Perlbal->service_names) {
my Perlbal::Service $svc = Perlbal->service($sname);
next unless $svc;
$body .= "<li><a href='/service?$sname'>$sname</a> - $svc->{role} ($svc->{listen})</li>\n";
}
$body .= "</ul></li>";
$body .= "</ul>";
} elsif ($uri eq "/socks") {
$prebox->('socks summary');
$prebox->('socks', sub {
${$_[0]} =~ s!service \'(\w+)\'!<a href=\"/service?$1\">$1</a>!;
});
} elsif ($uri eq "/obj") {
$prebox->('obj');
} elsif ($uri =~ m!^/service\?(\w+)$!) {
my $service = $1;
$prebox->("show service $service");
} else {
$code = "404 Not found";
$body .= "<h1>$code</h1>";
}
$body .= "<hr style='margin-top: 10px' /><a href='/'>Perlbal management</a>.\n";
$self->write("HTTP/1.0 $code\r\nContent-type: text/html\r\nContent-Length: " . length($body) .
"\r\n\r\n$body");
$self->write(sub { $self->close; });
return;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

507
wcmtools/perlbal/lib/Perlbal/ClientProxy.pm Executable file
View File

@@ -0,0 +1,507 @@
######################################################################
# HTTP Connection from a reverse proxy client
######################################################################
package Perlbal::ClientProxy;
use strict;
use warnings;
use base "Perlbal::ClientHTTPBase";
use fields (
'backend', # Perlbal::BackendHTTP object (or undef if disconnected)
'backend_requested', # true if we've requested a backend for this request
'reconnect_count', # number of times we've tried to reconnect to backend
'high_priority', # boolean; 1 if we are or were in the high priority queue
'reproxy_uris', # arrayref; URIs to reproxy to, in order
'reproxy_expected_size', # int: size of response we expect to get back for reproxy
'currently_reproxying', # arrayref; the host info and URI we're reproxying right now
'content_length_remain', # int: amount of data we're still waiting for
'responded', # bool: whether we've already sent a response to the user or not
'last_request_time', # int: time that we last received a request
'primary_res_hdrs', # if defined, we are doing a transparent reproxy-URI
# and the headers we get back aren't necessarily
# the ones we want. instead, get most headers
# from the provided res headers object here.
);
use constant READ_SIZE => 4096; # 4k, arbitrary
use constant READ_AHEAD_SIZE => 8192; # 8k, arbitrary
use Errno qw( EPIPE );
use POSIX ();
# ClientProxy
sub new {
my ($class, $service, $sock) = @_;
my $self = $class;
$self = fields::new($class) unless ref $self;
$self->SUPER::new($service, $sock); # init base fields
Perlbal::objctor($self);
$self->{last_request_time} = 0;
$self->{read_buf} = []; # scalar refs of bufs read from client
$self->{read_ahead} = 0; # bytes sitting in read_buf
$self->{read_size} = 0; # total bytes read from client
$self->{backend} = undef;
$self->{high_priority} = 0;
$self->{responded} = 0;
$self->{content_length_remain} = undef;
$self->{backend_requested} = 0;
$self->{reproxy_uris} = undef;
$self->{reproxy_expected_size} = undef;
$self->{currently_reproxying} = undef;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
# call this with a string of space separated URIs to start a process
# that will fetch the item at the first and return it to the user,
# on failure it will try the second, then third, etc
sub start_reproxy_uri {
my Perlbal::ClientProxy $self = $_[0];
my Perlbal::HTTPHeaders $primary_res_hdrs = $_[1];
my $urls = $_[2];
# at this point we need to disconnect from our backend
$self->{backend} = undef;
# failure if we have no primary response headers
return unless $self->{primary_res_hdrs} ||= $primary_res_hdrs;
# construct reproxy_uri list
if (defined $urls) {
my @uris = split /\s+/, $urls;
$self->{currently_reproxying} = undef;
$self->{reproxy_uris} = [];
foreach my $uri (@uris) {
next unless $uri =~ m!^http://(.+?)(?::(\d+))?(/.*)?$!;
push @{$self->{reproxy_uris}}, [ $1, $2 || 80, $3 || '/' ];
}
}
# if we get in here and we have currently_reproxying defined, then something
# happened and we want to retry that one
if ($self->{currently_reproxying}) {
unshift @{$self->{reproxy_uris}}, $self->{currently_reproxying};
$self->{currently_reproxying} = undef;
}
# if we have no uris in our list now, tell the user 404
return $self->_simple_response(503)
unless @{$self->{reproxy_uris} || []};
# set the expected size if we got a content length in our headers
if ($primary_res_hdrs && (my $expected_size = $primary_res_hdrs->header('X-REPROXY-EXPECTED-SIZE'))) {
$self->{reproxy_expected_size} = $expected_size;
}
# pass ourselves off to the reproxy manager
$self->state('wait_backend');
Perlbal::ReproxyManager::do_reproxy($self);
}
# called by the reproxy manager when we can't get to our requested backend
sub try_next_uri {
my Perlbal::ClientProxy $self = $_[0];
shift @{$self->{reproxy_uris}};
$self->{currently_reproxying} = undef;
$self->start_reproxy_uri();
}
# this is a callback for when a backend has been created and is
# ready for us to do something with it
sub use_reproxy_backend {
my Perlbal::ClientProxy $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# get a URI
my $datref = $self->{currently_reproxying} = shift @{$self->{reproxy_uris}};
unless (defined $datref) {
# return error and close the backend
$be->close('invalid_uris');
return $self->_simple_response(503);
}
# now send request
$self->{backend} = $be;
$be->{client} = $self;
my $headers = "GET $datref->[2] HTTP/1.0\r\nConnection: keep-alive\r\n\r\n";
$be->{req_headers} = Perlbal::HTTPHeaders->new(\$headers);
$be->state('sending_req');
$self->state('backend_req_sent');
$be->write($be->{req_headers}->to_string_ref);
$be->watch_read(1);
$be->watch_write(1);
}
# this is called when a transient backend getting a reproxied URI has received
# a response from the server and is ready for us to deal with it
sub backend_response_received {
my Perlbal::ClientProxy $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# a response means that we are no longer currently waiting on a reproxy, and
# don't want to retry this URI
$self->{currently_reproxying} = undef;
# we fail if we got something that's NOT a 2xx code, OR, if we expected
# a certain size and got back something different
my $code = $be->{res_headers}->response_code + 0;
if ($code < 200 || $code > 299 ||
(defined $self->{reproxy_expected_size} &&
$self->{reproxy_expected_size} != $be->{res_headers}->header('Content-length'))) {
# fall back to an alternate URL
$be->{client} = undef;
$be->close('non_200_reproxy');
$self->try_next_uri;
return 1;
}
return 0;
}
sub start_reproxy_file {
my Perlbal::ClientProxy $self = shift;
my $file = shift; # filename to reproxy
my Perlbal::HTTPHeaders $hd = shift; # headers from backend, in need of cleanup
# at this point we need to disconnect from our backend
$self->{backend} = undef;
# call hook for pre-reproxy
return if $self->{service}->run_hook("start_file_reproxy", $self, \$file);
# set our expected size
if (my $expected_size = $hd->header('X-REPROXY-EXPECTED-SIZE')) {
$self->{reproxy_expected_size} = $expected_size;
}
# start an async stat on the file
$self->state('wait_stat');
Perlbal::AIO::aio_stat($file, sub {
# if the client's since disconnected by the time we get the stat,
# just bail.
return if $self->{closed};
my $size = -s _;
unless ($size) {
# FIXME: POLICY: 404 or retry request to backend w/o reproxy-file capability?
return $self->_simple_response(404);
}
if (defined $self->{reproxy_expected_size} && $self->{reproxy_expected_size} != $size) {
# 404; the file size doesn't match what we expected
return $self->_simple_response(404);
}
# if the thing we're reproxying is indeed a file, advertise that
# we support byteranges on it
if (-f _) {
$hd->header("Accept-Ranges", "bytes");
}
my ($status, $range_start, $range_end) = $self->{req_headers}->range($size);
my $not_satisfiable = 0;
if ($status == 416) {
$hd = Perlbal::HTTPHeaders->new_response(416);
$hd->header("Content-Range", $size ? "*/$size" : "*");
$not_satisfiable = 1;
}
# change the status code to 200 if the backend gave us 204 No Content
$hd->code(200) if $hd->response_code == 204;
# fixup the Content-Length header with the correct size (application
# doesn't need to provide a correct value if it doesn't want to stat())
if ($status == 200) {
$hd->header("Content-Length", $size);
} elsif ($status == 206) {
$hd->header("Content-Range", "$range_start-$range_end/$size");
$hd->header("Content-Length", $range_end - $range_start + 1);
$hd->code(206);
}
# don't send this internal header to the client:
$hd->header('X-REPROXY-FILE', undef);
# rewrite some other parts of the header
$self->setup_keepalive($hd);
# just send the header, now that we cleaned it.
$self->write($hd->to_string_ref);
if ($self->{req_headers}->request_method eq 'HEAD' || $not_satisfiable) {
$self->write(sub { $self->http_response_sent; });
return;
}
$self->state('wait_open');
Perlbal::AIO::aio_open($file, 0, 0 , sub {
my $fh = shift;
# if client's gone, just close filehandle and abort
if ($self->{closed}) {
CORE::close($fh) if $fh;
return;
}
# handle errors
if (! $fh) {
# FIXME: do 500 vs. 404 vs whatever based on $! ?
return $self->_simple_response(500);
}
# seek if partial content
if ($status == 206) {
sysseek($fh, $range_start, &POSIX::SEEK_SET);
$size = $range_end - $range_start + 1;
}
$self->reproxy_fh($fh, $size);
$self->watch_write(1);
});
});
}
# Client
# get/set backend proxy connection
sub backend {
my Perlbal::ClientProxy $self = shift;
return $self->{backend} unless @_;
my $backend = shift;
$self->state('draining_res') unless $backend;
return $self->{backend} = $backend;
}
# our backend enqueues a call to this method in our write buffer, so this is called
# right after we've finished sending all of the results to the user. at this point,
# if we were doing keep-alive, we don't close and setup for the next request.
sub backend_finished {
my Perlbal::ClientProxy $self = shift;
# mark ourselves as having responded (presumeably if we're here,
# the backend has responded already)
$self->{responded} = 1;
# our backend is done with us, so we disconnect ourselves from it
$self->{backend} = undef;
# now, two cases; undefined clr, or defined and zero, or defined and non-zero
if (defined $self->{content_length_remain}) {
# defined, so a POST, close if it's 0 or less
return $self->http_response_sent
if $self->{content_length_remain} <= 0;
} else {
# not defined, so we're ready for another connection?
return $self->http_response_sent;
}
}
# called when we've sent a response to a user fully and we need to reset state
sub http_response_sent {
my Perlbal::ClientProxy $self = $_[0];
# persistence logic is in ClientHTTPBase
return 0 unless $self->SUPER::http_response_sent;
# if we get here we're being persistent, reset our state
$self->{backend_requested} = 0;
$self->{backend} = undef;
$self->{high_priority} = 0;
$self->{reproxy_uris} = undef;
$self->{reproxy_expected_size} = undef;
$self->{currently_reproxying} = undef;
$self->{content_length_remain} = undef;
$self->{primary_res_hdrs} = undef;
$self->{responded} = 0;
return 1;
}
# Client (overrides and calls super)
sub close {
my Perlbal::ClientProxy $self = shift;
my $reason = shift;
# don't close twice
return if $self->{closed};
# signal that we're done
$self->{service}->run_hooks('end_proxy_request', $self);
# kill our backend if we still have one
if (my $backend = $self->{backend}) {
print "Client ($self) closing backend ($backend)\n" if Perlbal::DEBUG >= 1;
$self->backend(undef);
$backend->close($reason ? "proxied_from_client_close:$reason" : "proxied_from_client_close");
} else {
# if no backend, tell our service that we don't care for one anymore
$self->{service}->note_client_close($self);
}
# call ClientHTTPBase's close
$self->SUPER::close($reason);
}
# Client
sub event_write {
my Perlbal::ClientProxy $self = shift;
$self->SUPER::event_write;
# obviously if we're writing the backend has processed our request
# and we are responding/have responded to the user, so mark it so
$self->{responded} = 1;
# trigger our backend to keep reading, if it's still connected
if (my $backend = $self->{backend}) {
# figure out which maximum buffer size to use
my $buf_size = defined $backend->{service} ? $self->{service}->{buffer_size} : $self->{service}->{buffer_size_reproxy_url};
$backend->watch_read(1) if $self->{write_buf_size} < $buf_size;
}
}
# ClientProxy
sub event_read {
my Perlbal::ClientProxy $self = shift;
# mark alive so we don't get killed for being idle
$self->{alive_time} = time;
# used a few times below to trigger the send start
my $request_backend = sub {
return if $self->{backend_requested};
$self->{backend_requested} = 1;
$self->state('wait_backend');
$self->{service}->request_backend_connection($self);
$self->tcp_cork(1); # cork writes to self
};
unless ($self->{req_headers}) {
if (my $hd = $self->read_request_headers) {
print "Got headers! Firing off new backend connection.\n"
if Perlbal::DEBUG >= 2;
return if $self->{service}->run_hook('start_proxy_request', $self);
# if defined we're waiting on some amount of data. also, we have to
# subtract out read_size, which is the amount of data that was
# extra in the packet with the header that's part of the body.
$self->{content_length_remain} = $hd->content_length;
$self->{content_length_remain} -= $self->{read_size}
if defined $self->{content_length_remain};
# note that we've gotten a request
$self->{requests}++;
$self->{last_request_time} = $self->{alive_time};
# request a backend, or start buffering
if ($self->{service}->{buffer_backend_connect} && $self->{content_length_remain}) {
# buffer logic; note we don't do anything here except set our state and move on
$self->state('buffering_request');
} else {
# dispatch to backend
$request_backend->();
}
}
return;
}
# read data and send to backend (or buffer for later sending)
if ($self->{read_ahead} < ($self->{service}->{buffer_backend_connect} || READ_AHEAD_SIZE)) {
my $bref = $self->read(READ_SIZE);
my $backend = $self->backend;
$self->drain_read_buf_to($backend) if $backend;
if (! defined($bref)) {
$self->watch_read(0);
return;
}
my $len = length($$bref);
$self->{read_size} += $len;
$self->{content_length_remain} -= $len
if defined $self->{content_length_remain};
# just dump the read into the nether if we're dangling. that is
# the case when we send the headers to the backend and it responds
# before we're done reading from the client; therefore further
# reads from the client just need to be sent nowhere, because the
# RFC2616 section 8.2.3 says: "the server SHOULD NOT close the
# transport connection until it has read the entire request"
if ($self->{responded}) {
# in addition, if we're now out of data (clr == 0), then we should
# either close ourselves or get ready for another request
return $self->http_response_sent
if defined $self->{content_length_remain} &&
($self->{content_length_remain} <= 0);
# at this point, if the backend has responded then we just return
# as we don't want to send it on to them or buffer it up, which is
# what the code below does
return;
}
if ($backend) {
$backend->write($bref);
} else {
push @{$self->{read_buf}}, $bref;
$self->{read_ahead} += $len;
# this is when we have read all their data
$request_backend->()
if defined $self->{content_length_remain} &&
$self->{content_length_remain} <= 0;
}
} else {
# our buffer is full, so turn off reads for now
$self->watch_read(0);
# we've exceeded our buffer_backend_connect, start getting a backend for us
$request_backend->();
}
}
sub as_string {
my Perlbal::ClientProxy $self = shift;
my $ret = $self->SUPER::as_string;
if ($self->{backend}) {
my $ipport = $self->{backend}->{ipport};
$ret .= "; backend=$ipport";
} else {
$ret .= "; write_buf_size=$self->{write_buf_size}"
if $self->{write_buf_size} > 0;
}
$ret .= "; highpri" if $self->{high_priority};
$ret .= "; responded" if $self->{responded};
$ret .= "; waiting_for=" . $self->{content_length_remain}
if defined $self->{content_length_remain};
$ret .= "; reproxying" if $self->{currently_reproxying};
return $ret;
}
sub DESTROY {
Perlbal::objdtor($_[0]);
$_[0]->SUPER::DESTROY;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

411
wcmtools/perlbal/lib/Perlbal/HTTPHeaders.pm Executable file
View File

@@ -0,0 +1,411 @@
######################################################################
# HTTP header class (both request and response)
######################################################################
package Perlbal::HTTPHeaders;
use strict;
use warnings;
use fields (
'headers', # href; lowercase header -> comma-sep list of values
'origcase', # href; lowercase header -> provided case
'hdorder', # aref; order headers were received (canonical order)
'method', # scalar; request method (if GET request)
'uri', # scalar; request URI (if GET request)
'type', # 'res' or 'req'
'code', # HTTP response status code
'codetext', # status text that for response code
'ver', # version (string) "1.1"
'vernum', # version (number: major*1000+minor): "1.1" => 1001
'responseLine', # first line of HTTP response (if response)
'requestLine', # first line of HTTP request (if request)
);
our $HTTPCode = {
200 => 'OK',
204 => 'No Content',
206 => 'Partial Content',
304 => 'Not Modified',
400 => 'Bad request',
403 => 'Forbidden',
404 => 'Not Found',
416 => 'Request range not satisfiable',
500 => 'Internal Server Error',
501 => 'Not Implemented',
503 => 'Service Unavailable',
};
sub fail {
return undef unless Perlbal::DEBUG >= 1;
my $reason = shift;
print "HTTP parse failure: $reason\n" if Perlbal::DEBUG >= 1;
return undef;
}
sub http_code_english {
my Perlbal::HTTPHeaders $self = shift;
return $HTTPCode->{$self->{code}};
}
sub new_response {
my Perlbal::HTTPHeaders $self = shift;
$self = fields::new($self) unless ref $self;
my $code = shift;
$self->{headers} = {};
$self->{origcase} = {};
$self->{hdorder} = [];
$self->{method} = undef;
$self->{uri} = undef;
my $msg = $HTTPCode->{$code} || "";
$self->{responseLine} = "HTTP/1.0 $code $msg";
$self->{code} = $code;
$self->{type} = "httpres";
Perlbal::objctor($self, $self->{type});
return $self;
}
sub new {
my Perlbal::HTTPHeaders $self = shift;
$self = fields::new($self) unless ref $self;
my ($hstr_ref, $is_response) = @_;
# hstr: headers as a string ref
# is_response: bool; is HTTP response (as opposed to request). defaults to request.
my $absoluteURIHost = undef;
my @lines = split(/\r?\n/, $$hstr_ref);
$self->{headers} = {};
$self->{origcase} = {};
$self->{hdorder} = [];
$self->{method} = undef;
$self->{uri} = undef;
$self->{type} = ($is_response ? "res" : "req");
Perlbal::objctor($self, $self->{type});
# check request line
if ($is_response) {
$self->{responseLine} = (shift @lines) || "";
# check for valid response line
return fail("Bogus response line") unless
$self->{responseLine} =~ m!^HTTP\/(\d+)\.(\d+)\s+(\d+)\s+(.+)$!;
my ($ver_ma, $ver_mi, $code) = ($1, $2, $3);
$self->code($code, $4);
# version work so we know what version the backend spoke
unless (defined $ver_ma) {
($ver_ma, $ver_mi) = (0, 9);
}
$self->{ver} = "$ver_ma.$ver_mi";
$self->{vernum} = $ver_ma*1000 + $ver_mi;
} else {
$self->{requestLine} = (shift @lines) || "";
# check for valid request line
return fail("Bogus request line") unless
$self->{requestLine} =~ m!^(\w+) ((?:\*|(?:\S*?)))(?: HTTP/(\d+)\.(\d+))$!;
$self->{method} = $1;
$self->{uri} = $2;
my ($ver_ma, $ver_mi) = ($3, $4);
# now check uri for not being a uri
if ($self->{uri} =~ m!^http://([^/:]+?)(?::\d+)?(/.*)?$!) {
$absoluteURIHost = lc($1);
$self->{uri} = $2 || "/"; # "http://www.foo.com" yields no path, so default to "/"
}
# default to HTTP/0.9
unless (defined $ver_ma) {
($ver_ma, $ver_mi) = (0, 9);
}
$self->{ver} = "$ver_ma.$ver_mi";
$self->{vernum} = $ver_ma*1000 + $ver_mi;
}
my $last_header = undef;
foreach my $line (@lines) {
if ($line =~ /^\s/) {
next unless defined $last_header;
$self->{headers}{$last_header} .= $line;
} elsif ($line =~ /^([^\x00-\x20\x7f()<>@,;:\\\"\/\[\]?={}]+):\s*(.*)$/) {
# RFC 2616:
# sec 4.2:
# message-header = field-name ":" [ field-value ]
# field-name = token
# sec 2.2:
# token = 1*<any CHAR except CTLs or separators>
$last_header = lc($1);
if (defined $self->{headers}{$last_header}) {
if ($last_header eq "set-cookie") {
# cookie spec doesn't allow merged headers for set-cookie,
# so instead we do this hack so to_string below does the right
# thing without needing to be arrayref-aware or such. also
# this lets client code still modify/delete this data
# (but retrieving the value of "set-cookie" will be broken)
$self->{headers}{$last_header} .= "\r\nSet-Cookie: $2";
} else {
# normal merged header case (according to spec)
$self->{headers}{$last_header} .= ", $2";
}
} else {
$self->{headers}{$last_header} = $2;
$self->{origcase}{$last_header} = $1;
push @{$self->{hdorder}}, $last_header;
}
} else {
return fail("unknown header line");
}
}
# override the host header if an absolute URI was provided
$self->header('Host', $absoluteURIHost)
if defined $absoluteURIHost;
# now error if no host
return fail("HTTP 1.1 requires host header")
if !$is_response && $self->{vernum} >= 1001 && !$self->header('Host');
return $self;
}
sub _codetext {
my Perlbal::HTTPHeaders $self = shift;
return $self->{codetext} if $self->{codetext};
return $self->http_code_english;
}
sub code {
my Perlbal::HTTPHeaders $self = shift;
my ($code, $text) = @_;
$self->{code} = $code+0;
$self->{codetext} = $text;
}
sub response_code {
my Perlbal::HTTPHeaders $self = $_[0];
return $self->{code};
}
sub request_method {
my Perlbal::HTTPHeaders $self = shift;
return $self->{method};
}
sub request_uri {
my Perlbal::HTTPHeaders $self = shift;
return $self->{uri};
}
sub version_number {
my Perlbal::HTTPHeaders $self = $_[0];
return $self->{vernum} unless $_[1];
return $self->{vernum} = $_[1];
}
sub header {
my Perlbal::HTTPHeaders $self = shift;
my $key = shift;
return $self->{headers}{lc($key)} unless @_;
# adding a new header
my $origcase = $key;
$key = lc($key);
unless (exists $self->{headers}{$key}) {
push @{$self->{hdorder}}, $key;
$self->{origcase}{$key} = $origcase;
}
return $self->{headers}{$key} = shift;
}
sub to_string_ref {
my Perlbal::HTTPHeaders $self = shift;
my $st = join("\r\n",
$self->{requestLine} || $self->{responseLine},
(map { "$self->{origcase}{$_}: $self->{headers}{$_}" }
grep { defined $self->{headers}{$_} }
@{$self->{hdorder}}),
'', ''); # final \r\n\r\n
return \$st;
}
sub clone {
my Perlbal::HTTPHeaders $self = shift;
my $new = fields::new($self);
foreach (qw(method uri type code codetext ver vernum responseLine requestLine)) {
$new->{$_} = $self->{$_};
}
# mark this object as constructed
Perlbal::objctor($new, $new->{type});
$new->{headers} = { %{$self->{headers}} };
$new->{origcase} = { %{$self->{origcase}} };
$new->{hdorder} = [ @{$self->{hdorder}} ];
return $new;
}
sub set_version {
my Perlbal::HTTPHeaders $self = shift;
my $ver = shift;
die "Bogus version" unless $ver =~ /^(\d+)\.(\d+)$/;
my ($ver_ma, $ver_mi) = ($1, $2);
# check for req, as the other can be res or httpres
if ($self->{type} eq 'req') {
$self->{requestLine} = "$self->{method} $self->{uri} HTTP/$ver";
} else {
$self->{responseLine} = "HTTP/$ver $self->{code} " . $self->_codetext;
}
$self->{ver} = "$ver_ma.$ver_mi";
$self->{vernum} = $ver_ma*1000 + $ver_mi;
return $self;
}
# using all available information, attempt to determine the content length of
# the message body being sent to us.
sub content_length {
my Perlbal::HTTPHeaders $self = shift;
# shortcuts depending on our method/code, depending on what we are
if ($self->{type} eq 'req') {
# no content length for head requests
return 0 if $self->{method} eq 'HEAD';
} elsif ($self->{type} eq 'res' || $self->{type} eq 'httpres') {
# no content length in any of these
if ($self->{code} == 304 || $self->{code} == 204 ||
($self->{code} >= 100 && $self->{code} <= 199)) {
return 0;
}
}
# the normal case for a GET/POST, etc. real data coming back
# also, an OPTIONS requests generally has a defined but 0 content-length
if (defined(my $clen = $self->header("Content-Length"))) {
return $clen;
}
# if we get here, nothing matched, so we don't definitively know what the
# content length is. this is usually an error, but we try to work around it.
return undef;
}
# answers the question: "should a response to this person specify keep-alive,
# given the request (self) and the backend response?" this is used in proxy
# mode to determine based on the client's request and the backend's response
# whether or not the response from the proxy (us) should do keep-alive.
sub req_keep_alive {
my Perlbal::HTTPHeaders $self = $_[0];
my Perlbal::HTTPHeaders $res = $_[1];
# get the connection header now (saves warnings later)
my $conn = lc ($self->header('Connection') || '');
# check the client
if ($self->version_number < 1001) {
# they must specify a keep-alive header
return 0 unless $conn =~ /\bkeep-alive\b/i;
}
# so it must be 1.1 which means keep-alive is on, unless they say not to
return 0 if $conn =~ /\bclose\b/i;
# if we get here, the user wants keep-alive and seems to support it,
# so we make sure that the response is in a form that we can understand
# well enough to do keep-alive. FIXME: support chunked encoding in the
# future, which means this check changes.
return 1 if defined $res->header('Content-length') ||
$self->request_method eq 'HEAD';
# fail-safe, no keep-alive
return 0;
}
# answers the question: is the backend expected to stay open. this is a combination
# of the request we sent to it and the response they sent...
sub res_keep_alive {
my Perlbal::HTTPHeaders $self = $_[0];
my Perlbal::HTTPHeaders $req = $_[1];
# get the connection header now (saves warnings later)
my $conn = lc ($self->header('Connection') || '');
# if they said Connection: close, it's always not keep-alive
return 0 if $conn =~ /\bclose\b/i;
# handle the http 1.0/0.9 case which requires keep-alive specified
if ($self->version_number < 1001) {
# must specify keep-alive, and must have a content length OR
# the request must be a head request
return 1 if
$conn =~ /\bkeep-alive\b/i &&
(defined $self->header('Content-length') ||
$req->request_method eq 'HEAD');
return 0;
}
# HTTP/1.1 case. defaults to keep-alive, per spec, unless
# asked for otherwise (checked above)
# FIXME: make sure we handle a HTTP/1.1 response from backend
# with connection: close, no content-length, going to a
# HTTP/1.1 persistent client. we'll have to add chunk markers.
# (not here, obviously)
return 1;
}
# returns (status, range_start, range_end) when given a size
# status = 200 - invalid or non-existent range header. serve normally.
# status = 206 - parsable range is good. serve partial content.
# status = 416 - Range is unsatisfiable
sub range {
my Perlbal::HTTPHeaders $self = $_[0];
my $size = $_[1];
my $not_satisfiable;
my $range = $self->header("Range");
return 200 unless $range && defined $size;
my ($range_start, $range_end) = $range =~ /^bytes=(\d*)-(\d*)$/;
undef $range_start if $range_start eq '';
undef $range_end if $range_end eq '';
return 200 unless defined($range_start) or defined($range_end);
if (defined($range_start) and defined($range_end) and $range_start > $range_end) {
return 416;
} elsif (not defined($range_start) and defined($range_end) and $range_end == 0) {
return 416;
} elsif (defined($range_start) and $size <= $range_start) {
return 416;
}
$range_start = 0 unless defined($range_start);
$range_end = $size - 1 unless defined($range_end) and $range_end < $size;
return (206, $range_start, $range_end);
}
sub DESTROY {
my Perlbal::HTTPHeaders $self = shift;
Perlbal::objdtor($self, $self->{type});
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

124
wcmtools/perlbal/lib/Perlbal/Plugin/Highpri.pm Executable file
View File

@@ -0,0 +1,124 @@
###########################################################################
# plugin that makes some requests high priority. this is very LiveJournal
# specific, as this makes requests to the client protocol be treated as
# high priority requests.
###########################################################################
package Perlbal::Plugin::Highpri;
use strict;
use warnings;
# keep track of services we're loaded for
our %Services;
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# create a compiled regexp for very frequent use later
my $uri_check = qr{^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$};
my $host_check = undef;
# setup default extra config info
$svc->{extra_config}->{highpri_uri_check_str} = '^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$';
$svc->{extra_config}->{highpri_host_check_str} = 'undef';
# config setter reference
my $config_set = sub {
my ($out, $what, $val) = @_;
return 0 unless $what && $val;
# setup an error sub
my $err = sub {
$out->("ERROR: $_[0]") if $out;
return 0;
};
# if they said undef, that's not a regexp, that means use none
my $temp;
unless ($val eq 'undef' || $val eq 'none' || $val eq 'null') {
# verify this regex works? do it in an eval because qr will die
# if we give it something invalid
eval {
$temp = qr{$val};
};
return $err->("Invalid regular expression") if $@ || !$temp;
}
# see what they want to set and set it
if ($what =~ /^uri_pattern/i) {
$uri_check = $temp;
$svc->{extra_config}->{highpri_uri_check_str} = $val;
} elsif ($what =~ /^host_pattern/i) {
$host_check = $temp;
$svc->{extra_config}->{highpri_host_check_str} = $val;
} else {
return $err->("Plugin understands: uri_pattern, host_pattern");
}
# 1 for success!
return 1;
};
# register things to take in configuration regular expressions
$svc->register_setter('Highpri', 'uri_pattern', $config_set);
$svc->register_setter('Highpri', 'host_pattern', $config_set);
# more complicated statistics
$svc->register_hook('Highpri', 'make_high_priority', sub {
my Perlbal::ClientProxy $cp = shift;
# check it against our compiled regexp
return 1 if $uri_check &&
$cp->{req_headers}->request_uri =~ /$uri_check/;
if ($host_check) {
my $hostname = $cp->{req_headers}->header('Host');
return 1 if $hostname && $hostname =~ /$host_check/;
}
# doesn't fit, so return 0
return 0;
});
# mark this service as being active in this plugin
$Services{"$svc"} = $svc;
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Highpri');
$svc->unregister_setters('Highpri');
return 1;
}
# load global commands for querying this plugin on what's up
sub load {
# setup a command to see what the patterns are
Perlbal::register_global_hook('manage_command.patterns', sub {
my @res = ("High priority pattern buffer:");
foreach my $svc (values %Services) {
push @res, "SET $svc->{name}.highpri.uri_pattern = $svc->{extra_config}->{highpri_uri_check_str}";
push @res, "SET $svc->{name}.highpri.host_pattern = $svc->{extra_config}->{highpri_host_check_str}";
}
return \@res;
});
return 1;
}
# unload our global commands, clear our service object
sub unload {
Perlbal::unregister_global_hook('manage_command.patterns');
%Services = ();
return 1;
}
1;

293
wcmtools/perlbal/lib/Perlbal/Plugin/Palimg.pm Executable file
View File

@@ -0,0 +1,293 @@
###########################################################################
# Palimg plugin that allows Perlbal to serve palette altered images
###########################################################################
package Perlbal::Plugin::Palimg;
use strict;
use warnings;
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# verify that an incoming request is a palimg request
$svc->register_hook('Palimg', 'start_serve_request', sub {
my Perlbal::ClientHTTPBase $obj = $_[0];
return 0 unless $obj;
my Perlbal::HTTPHeaders $hd = $obj->{req_headers};
my $uriref = $_[1];
return 0 unless $uriref;
# if this is palimg, peel off the requested modifications and put in headers
return 0 unless $$uriref =~ m!^/palimg/(.+)\.(\w+)(.*)$!;
my ($fn, $ext, $extra) = ($1, $2, $3);
return 0 unless $extra;
my ($palspec) = $extra =~ m!^/p(.+)$!;
return 0 unless $fn && $palspec;
# must be ok, setup for it
$$uriref = "/palimg/$fn.$ext";
$obj->{scratch}->{palimg} = [ $ext, $palspec ];
return 0;
});
# actually serve a palimg
$svc->register_hook('Palimg', 'start_send_file', sub {
my Perlbal::ClientHTTPBase $obj = $_[0];
return 0 unless $obj &&
(my $palimginfo = $obj->{scratch}->{palimg});
# turn off writes
$obj->watch_write(0);
# create filehandle for reading
my $data = '';
Perlbal::AIO::aio_read($obj->reproxy_fh, 0, 2048, $data, sub {
# got data? undef is error
return $obj->_simple_response(500) unless $_[0] > 0;
# pass down to handler
my Perlbal::HTTPHeaders $hd = $obj->{req_headers};
my $res = PalImg::modify_file(\$data, $palimginfo->[0], $palimginfo->[1]);
return $obj->_simple_response(500) unless defined $res;
return $obj->_simple_response($res) if $res;
# seek into the file now so sendfile starts further in
my $ld = length $data;
sysseek($obj->{reproxy_fh}, $ld, &POSIX::SEEK_SET);
$obj->{reproxy_file_offset} = $ld;
# reenable writes after we get data
$obj->tcp_cork(1); # by setting reproxy_file_offset above, it won't cork, so we cork it
$obj->write($data);
$obj->watch_write(1);
});
return 1;
});
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Palimg');
return 1;
}
# called when we are loaded/unloaded ... someday add some stats viewing
# commands here?
sub load { return 1; }
sub unload { return 1; }
####### PALIMG START ###########################################################################
package PalImg;
sub parse_hex_color
{
my $color = shift;
return [ map { hex(substr($color, $_, 2)) } (0,2,4) ];
}
sub modify_file
{
my ($data, $type, $palspec) = @_;
# palette altering
my %pal_colors;
if (my $pals = $palspec) {
my $hx = "[0-9a-f]";
if ($pals =~ /^g($hx{2,2})($hx{6,6})($hx{2,2})($hx{6,6})$/) {
# gradient from index $1, color $2, to index $3, color $4
my $from = hex($1);
my $to = hex($3);
return 404 if $from == $to;
my $fcolor = parse_hex_color($2);
my $tcolor = parse_hex_color($4);
if ($to < $from) {
($from, $to, $fcolor, $tcolor) =
($to, $from, $tcolor, $fcolor);
}
for (my $i=$from; $i<=$to; $i++) {
$pal_colors{$i} = [ map {
int($fcolor->[$_] +
($tcolor->[$_] - $fcolor->[$_]) *
($i-$from) / ($to-$from))
} (0..2) ];
}
} elsif ($pals =~ /^t($hx{6,6})($hx{6,6})?$/) {
# tint everything towards color
my ($t, $td) = ($1, $2);
$pal_colors{'tint'} = parse_hex_color($t);
$pal_colors{'tint_dark'} = $td ? parse_hex_color($td) : [0,0,0];
} elsif (length($pals) > 42 || $pals =~ /[^0-9a-f]/) {
return 404;
} else {
my $len = length($pals);
return 404 if $len % 7; # must be multiple of 7 chars
for (my $i = 0; $i < $len/7; $i++) {
my $palindex = hex(substr($pals, $i*7, 1));
$pal_colors{$palindex} = [
hex(substr($pals, $i*7+1, 2)),
hex(substr($pals, $i*7+3, 2)),
hex(substr($pals, $i*7+5, 2)),
substr($pals, $i*7+1, 6),
];
}
}
}
if (%pal_colors) {
if ($type eq 'gif') {
return 404 unless PaletteModify::new_gif_palette($data, \%pal_colors);
} elsif ($type eq 'png') {
return 404 unless PaletteModify::new_png_palette($data, \%pal_colors);
}
}
# success
return 0;
}
####### PALIMG END #############################################################################
####### PALETTEMODIFY START ####################################################################
package PaletteModify;
BEGIN {
$PaletteModify::HAVE_CRC = eval "use String::CRC32 (); 1;";
}
sub common_alter
{
my ($palref, $table) = @_;
my $length = length $table;
my $pal_size = $length / 3;
# tinting image? if so, we're remaking the whole palette
if (my $tint = $palref->{'tint'}) {
my $dark = $palref->{'tint_dark'};
my $diff = [ map { $tint->[$_] - $dark->[$_] } (0..2) ];
$palref = {};
for (my $idx=0; $idx<$pal_size; $idx++) {
for my $c (0..2) {
my $curr = ord(substr($table, $idx*3+$c));
my $p = \$palref->{$idx}->[$c];
$$p = int($dark->[$c] + $diff->[$c] * $curr / 255);
}
}
}
while (my ($idx, $c) = each %$palref) {
next if $idx >= $pal_size;
substr($table, $idx*3+$_, 1) = chr($c->[$_]) for (0..2);
}
return $table;
}
sub new_gif_palette
{
my ($data, $palref) = @_;
# make sure we have data to operate on, or the substrs below die
return unless $$data;
# 13 bytes for magic + image info (size, color depth, etc)
# and then the global palette table (3*256)
my $header = substr($$data, 0, 13+3*256);
# figure out how big global color table is (don't want to overwrite it)
my $pf = ord substr($header, 10, 1);
my $gct = 2 ** (($pf & 7) + 1); # last 3 bits of packaged fields
# final sanity check for size so the substr below doesn't die
return unless length $header >= 13 + 3 * $gct;
substr($header, 13, 3*$gct) = common_alter($palref, substr($header, 13, 3*$gct));
$$data = $header;
return 1;
}
sub new_png_palette
{
my ($data, $palref) = @_;
# subroutine for reading data
my ($curidx, $maxlen) = (0, length $$data);
my $read = sub {
# put $_[1] data into scalar reference $_[0]
return undef if $_[1] + $curidx > $maxlen;
${$_[0]} = substr($$data, $curidx, $_[1]);
$curidx += $_[1];
return length ${$_[0]};
};
# without this module, we can't proceed.
return 0 unless $PaletteModify::HAVE_CRC;
my $imgdata;
# Validate PNG signature
my $png_sig = pack("H16", "89504E470D0A1A0A");
my $sig;
$read->(\$sig, 8);
return 0 unless $sig eq $png_sig;
$imgdata .= $sig;
# Start reading in chunks
my ($length, $type) = (0, '');
while ($read->(\$length, 4)) {
$imgdata .= $length;
$length = unpack("N", $length);
return 0 unless $read->(\$type, 4) == 4;
$imgdata .= $type;
if ($type eq 'IHDR') {
my $header;
$read->(\$header, $length+4);
my ($width,$height,$depth,$color,$compression,
$filter,$interlace, $CRC)
= unpack("NNCCCCCN", $header);
return 0 unless $color == 3; # unpaletted image
$imgdata .= $header;
} elsif ($type eq 'PLTE') {
# Finally, we can go to work
my $palettedata;
$read->(\$palettedata, $length);
$palettedata = common_alter($palref, $palettedata);
$imgdata .= $palettedata;
# Skip old CRC
my $skip;
$read->(\$skip, 4);
# Generate new CRC
my $crc = String::CRC32::crc32($type . $palettedata);
$crc = pack("N", $crc);
$imgdata .= $crc;
$$data = $imgdata;
return 1;
} else {
my $skip;
# Skip rest of chunk and add to imgdata
# Number of bytes is +4 becauses of CRC
#
for (my $count=0; $count < $length + 4; $count++) {
$read->(\$skip, 1);
$imgdata .= $skip;
}
}
}
return 0;
}
####### PALETTEMODIFY END ######################################################################
1;

54
wcmtools/perlbal/lib/Perlbal/Plugin/Queues.pm Executable file
View File

@@ -0,0 +1,54 @@
###########################################################################
# simple queue length header inclusion plugin
###########################################################################
package Perlbal::Plugin::Queues;
use strict;
use warnings;
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# more complicated statistics
$svc->register_hook('Queues', 'backend_client_assigned', sub {
my Perlbal::BackendHTTP $obj = shift;
my Perlbal::HTTPHeaders $hds = $obj->{req_headers};
my Perlbal::Service $svc = $obj->{service};
return 0 unless defined $hds && defined $svc;
# determine age of oldest (first in line)
my $now = time;
my Perlbal::ClientProxy $cp = $svc->{waiting_clients}->[0];
my $age = defined $cp ? ($now - $cp->{last_request_time}) : 0;
# now do the age of the high priority queue
$cp = $svc->{waiting_clients_highpri}->[0];
my $hpage = defined $cp ? ($now - $cp->{last_request_time}) : 0;
# setup the queue length headers
$hds->header('X-Queue-Count', scalar(@{$svc->{waiting_clients}}));
$hds->header('X-Queue-Age', $age);
$hds->header('X-HP-Queue-Count', scalar(@{$svc->{waiting_clients_highpri}}));
$hds->header('X-HP-Queue-Age', $hpage);
return 0;
});
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Queues');
return 1;
}
# we don't do anything in here
sub load { return 1; }
sub unload { return 1; }
1;

161
wcmtools/perlbal/lib/Perlbal/Plugin/Stats.pm Executable file
View File

@@ -0,0 +1,161 @@
###########################################################################
# basic Perlbal statistics gatherer
###########################################################################
package Perlbal::Plugin::Stats;
use strict;
use warnings;
use Time::HiRes qw(gettimeofday tv_interval);
# setup our package variables
our %statobjs; # { svc_name => [ service, statobj ], svc_name => [ service, statobj ], ... }
# define all stats keys here
our @statkeys = qw( files_sent files_reproxied
web_requests proxy_requests
proxy_requests_highpri );
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# create a stats object
my $sobj = Perlbal::Plugin::Stats::Storage->new();
$statobjs{$svc->{name}} = [ $svc, $sobj ];
# simple events we count are done here. when the hook on the left side is called,
# we simply increment the count of the stat ont he right side.
my %simple = qw(
start_send_file files_sent
start_file_reproxy files_reproxied
start_web_request web_requests
);
# create hooks for %simple things
while (my ($hook, $stat) = each %simple) {
eval "\$svc->register_hook('Stats', '$hook', sub { \$sobj->{'$stat'}++; return 0; });";
return undef if $@;
}
# more complicated statistics
$svc->register_hook('Stats', 'backend_client_assigned', sub {
my Perlbal::BackendHTTP $be = shift;
$sobj->{pending}->{"$be->{client}"} = [ gettimeofday() ];
($be->{client}->{high_priority} ? $sobj->{proxy_requests_highpri} : $sobj->{proxy_requests})++;
return 0;
});
$svc->register_hook('Stats', 'backend_response_received', sub {
my Perlbal::BackendHTTP $be = shift;
my Perlbal::ClientProxy $obj = $be->{client};
my $ot = $sobj->{pending}->{"$obj"};
return 0 unless defined $ot;
# now construct data to put in recent
if (defined $obj->{req_headers}) {
my $uri = 'http://' . ($obj->{req_headers}->header('Host') || 'unknown') . $obj->{req_headers}->request_uri;
push @{$sobj->{recent}}, sprintf('%-6.4f %s', tv_interval($ot), $uri);
shift(@{$sobj->{recent}}) if scalar(@{$sobj->{recent}}) > 100; # if > 100 items, lose one
}
return 0;
});
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Stats');
delete $statobjs{$svc->{name}};
return 1;
}
# called when we are loaded
sub load {
# setup a management command to dump statistics
Perlbal::register_global_hook("manage_command.stats", sub {
my @res;
# create temporary object for stats storage
my $gsobj = Perlbal::Plugin::Stats::Storage->new();
# dump per service
foreach my $svc (keys %statobjs) {
my $sobj = $statobjs{$svc}->[1];
# for now, simply dump the numbers we have
foreach my $key (sort @statkeys) {
push @res, sprintf("%-15s %-25s %12d", $svc, $key, $sobj->{$key});
$gsobj->{$key} += $sobj->{$key};
}
}
# global stats
foreach my $key (sort @statkeys) {
push @res, sprintf("%-15s %-25s %12d", 'total', $key, $gsobj->{$key});
}
return \@res;
});
# recent requests and how long they took
Perlbal::register_global_hook("manage_command.recent", sub {
my @res;
foreach my $svc (keys %statobjs) {
my $sobj = $statobjs{$svc}->[1];
push @res, "$svc $_"
foreach @{$sobj->{recent}};
}
return \@res;
});
return 1;
}
# called for a global unload
sub unload {
# unregister our global hooks
Perlbal::unregister_global_hook('manage_command.stats');
Perlbal::unregister_global_hook('manage_command.recent');
# take out all service stuff
foreach my $statref (values %statobjs) {
$statref->[0]->unregister_hooks('Stats');
}
%statobjs = ();
return 1;
}
# statistics storage object
package Perlbal::Plugin::Stats::Storage;
use fields (
'files_sent', # files sent from disk (includes reproxies and regular web requests)
'files_reproxied', # files we've sent via reproxying (told to by backend)
'web_requests', # requests we sent ourselves (no reproxy, no backend)
'proxy_requests', # regular requests that went to a backend to be served
'proxy_requests_highpri', # same as above, except high priority
'pending', # hashref; { "obj" => time_start }
'recent', # arrayref; strings of recent URIs and times
);
sub new {
my Perlbal::Plugin::Stats::Storage $self = shift;
$self = fields::new($self) unless ref $self;
# 0 initialize everything here
$self->{$_} = 0 foreach @Perlbal::Plugin::Stats::statkeys;
# other setup
$self->{pending} = {};
$self->{recent} = [];
return $self;
}
1;

328
wcmtools/perlbal/lib/Perlbal/Pool.pm Executable file
View File

@@ -0,0 +1,328 @@
######################################################################
# Pool class
######################################################################
package Perlbal::Pool;
use strict;
use warnings;
use Perlbal::BackendHTTP;
# how often to reload the nodefile
use constant NODEFILE_RELOAD_FREQ => 3;
# balance methods we support
use constant BM_SENDSTATS => 1;
use constant BM_ROUNDROBIN => 2;
use constant BM_RANDOM => 3;
use fields (
'name', # string; name of this pool
'use_count', # int; number of services using us
'nodes', # arrayref; [ip, port] values (port defaults to 80)
'node_count', # int; number of nodes
'node_used', # hashref; { ip:port => use count }
'balance_method', # int; BM_ constant from above
# used in sendstats mode
'sendstats.listen', # what IP/port the stats listener runs on
'sendstats.listen.socket', # Perlbal::StatsListener object
# used in nodefile mode
'nodefile', # string; filename to read nodes from
'nodefile.lastmod', # unix time nodefile was last modified
'nodefile.lastcheck', # unix time nodefile was last stated
'nodefile.checking', # boolean; if true AIO is stating the file for us
);
sub new {
my Perlbal::Pool $self = shift;
$self = fields::new($self) unless ref $self;
my ($name) = @_;
$self->{name} = $name;
$self->{use_count} = 0;
$self->{nodes} = [];
$self->{node_count} = 0;
$self->{node_used} = {};
$self->{nodefile} = undef;
$self->{balance_method} = BM_RANDOM;
return $self;
}
sub set {
my Perlbal::Pool $self = shift;
my ($key, $val, $out, $verbose) = @_;
my $err = sub { $out->("ERROR: $_[0]"); return 0; };
my $ok = sub { $out->("OK") if $verbose; return 1; };
my $set = sub { $self->{$key} = $val; return $ok->(); };
if ($key eq 'nodefile') {
# allow to unset it, which stops us from checking it further,
# but doesn't clear our current list of nodes
if ($val =~ /^(?:none|undef|null|""|'')$/) {
$self->{'nodefile'} = undef;
$self->{'nodefile.lastmod'} = 0;
$self->{'nodefile.checking'} = 0;
$self->{'nodefile.lastcheck'} = 0;
return $ok->();
}
# enforce that it exists from here on out
return $err->("File not found")
unless -e $val;
# force a reload
$self->{'nodefile'} = $val;
$self->{'nodefile.lastmod'} = 0;
$self->{'nodefile.checking'} = 0;
$self->load_nodefile;
$self->{'nodefile.lastcheck'} = time;
return $ok->();
}
if ($key eq "balance_method") {
$val = {
'sendstats' => BM_SENDSTATS,
'random' => BM_RANDOM,
}->{$val};
return $err->("Unknown balance method")
unless $val;
return $set->();
}
if ($key =~ /^sendstats\./) {
return $err->("Can only set sendstats listening address on service with balancing method 'sendstats'")
unless $self->{balance_method} == BM_SENDSTATS;
if ($key eq "sendstats.listen") {
return $err->("Invalid host:port")
unless $val =~ m!^\d+\.\d+\.\d+\.\d+:\d+$!;
if (my $pbs = $self->{"sendstats.listen.socket"}) {
$pbs->close;
}
unless ($self->{"sendstats.listen.socket"} =
Perlbal::StatsListener->new($val, $self)) {
return $err->("Error creating stats listener: $Perlbal::last_error");
}
$self->populate_sendstats_hosts;
}
return $set->();
}
}
sub populate_sendstats_hosts {
my Perlbal::Pool $self = shift;
# tell the sendstats listener about the new list of valid
# IPs to listen from
if ($self->{balance_method} == BM_SENDSTATS) {
my $ss = $self->{'sendstats.listen.socket'};
$ss->set_hosts(map { $_->[0] } @{$self->{nodes}}) if $ss;
}
}
# returns string of balance method
sub balance_method {
my Perlbal::Pool $self = $_[0];
my $methods = {
&BM_SENDSTATS => "sendstats",
&BM_ROUNDROBIN => "round_robin",
&BM_RANDOM => "random",
};
return $methods->{$self->{balance_method}} || $self->{balance_method};
}
sub load_nodefile {
my Perlbal::Pool $self = shift;
return 0 unless $self->{'nodefile'};
if ($Perlbal::OPTMOD_LINUX_AIO) {
return $self->_load_nodefile_async;
} else {
return $self->_load_nodefile_sync;
}
}
sub _parse_nodefile {
my Perlbal::Pool $self = shift;
my $dataref = shift;
my @nodes = split(/\r?\n/, $$dataref);
# prepare for adding nodes
$self->{nodes} = [];
$self->{node_used} = {};
foreach (@nodes) {
s/\#.*//;
if (/(\d+\.\d+\.\d+\.\d+)(?::(\d+))?/) {
my ($ip, $port) = ($1, $2);
$self->{node_used}->{"$ip:$port"} ||= 0; # set to 0 if not set
push @{$self->{nodes}}, [ $ip, $port || 80 ];
}
}
# setup things using new data
$self->{node_count} = scalar @{$self->{nodes}};
$self->populate_sendstats_hosts;
}
sub _load_nodefile_sync {
my Perlbal::Pool $self = shift;
my $mod = (stat($self->{nodefile}))[9];
return if $mod == $self->{'nodefile.lastmod'};
$self->{'nodefile.lastmod'} = $mod;
open NODEFILE, $self->{nodefile} or return;
my $nodes;
{ local $/ = undef; $nodes = <NODEFILE>; }
close NODEFILE;
$self->_parse_nodefile(\$nodes);
}
sub _load_nodefile_async {
my Perlbal::Pool $self = shift;
return if $self->{'nodefile.checking'};
$self->{'nodefile.checking'} = 1;
Perlbal::AIO::aio_stat($self->{nodefile}, sub {
$self->{'nodefile.checking'} = 0;
# this might have gotten unset while we were out statting the file, which
# means that the user has instructed us not to use a node file, and may
# have changed the nodes in the pool, so we should do nothing and return
return unless $self->{'nodefile'};
# ignore if the file doesn't exist
return unless -e _;
my $mod = (stat(_))[9];
return if $mod == $self->{'nodefile.lastmod'};
$self->{'nodefile.lastmod'} = $mod;
# construct a filehandle (we only have a descriptor here)
open NODEFILE, $self->{nodefile}
or return;
my $nodes;
{ local $/ = undef; $nodes = <NODEFILE>; }
close NODEFILE;
$self->_parse_nodefile(\$nodes);
return;
});
return 1;
}
sub add {
my Perlbal::Pool $self = shift;
my ($ip, $port) = @_;
$self->remove($ip, $port); # no dupes
$self->{node_used}->{"$ip:$port"} = 0;
push @{$self->{nodes}}, [ $ip, $port ];
$self->{node_count} = scalar(@{$self->{nodes}});
}
sub remove {
my Perlbal::Pool $self = shift;
my ($ip, $port) = @_;
delete $self->{node_used}->{"$ip:$port"};
@{$self->{nodes}} = grep { "$_->[0]:$_->[1]" ne "$ip:$port" } @{$self->{nodes}};
$self->{node_count} = scalar(@{$self->{nodes}});
}
sub get_backend_endpoint {
my Perlbal::Pool $self = $_[0];
my @endpoint; # (IP,port)
# re-load nodefile if necessary
if ($self->{nodefile}) {
my $now = time;
if ($now > $self->{'nodefile.lastcheck'} + NODEFILE_RELOAD_FREQ) {
$self->{'nodefile.lastcheck'} = $now;
$self->load_nodefile;
}
}
if ($self->{balance_method} == BM_SENDSTATS) {
my $ss = $self->{'sendstats.listen.socket'};
if ($ss && (@endpoint = $ss->get_endpoint)) {
return @endpoint;
}
}
# no nodes?
return () unless $self->{node_count};
# pick one randomly
return @{$self->{nodes}[int(rand($self->{node_count}))]};
}
sub backend_should_live {
my Perlbal::Pool $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# a backend stays alive if we still have users. eventually this whole
# function might do more and actually take into account the individual
# backend, but for now, this suits us.
return 1 if $self->{use_count};
return 0;
}
sub node_count {
my Perlbal::Pool $self = $_[0];
return $self->{node_count};
}
sub nodes {
my Perlbal::Pool $self = $_[0];
return $self->{nodes};
}
sub node_used {
my Perlbal::Pool $self = $_[0];
return $self->{node_used}->{$_[1]};
}
sub mark_node_used {
my Perlbal::Pool $self = $_[0];
$self->{node_used}->{$_[1]}++;
}
sub increment_use_count {
my Perlbal::Pool $self = $_[0];
$self->{use_count}++;
}
sub decrement_use_count {
my Perlbal::Pool $self = $_[0];
$self->{use_count}--;
}
sub name {
my Perlbal::Pool $self = $_[0];
return $self->{name};
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

248
wcmtools/perlbal/lib/Perlbal/ReproxyManager.pm Executable file
View File

@@ -0,0 +1,248 @@
######################################################################
# HTTP connection to backend node
# possible states: connecting, bored, sending_req, wait_res, xfer_res
######################################################################
package Perlbal::ReproxyManager;
use strict;
use warnings;
# class storage to store 'host:ip' => $service objects, for making
# reproxies use a service that you can then track
our $ReproxySelf;
our %ReproxyConnecting; # ( host:ip => $backend ); keeps track of outstanding connections to backend that
# are in the connecting state
our %ReproxyBored; # ( host:ip => [ $backend, ... ] ); list of our bored backends
our %ReproxyQueues; # ( host:ip => [ $clientproxy, ... ] ); queued up requests for this backend
our %ReproxyBackends; # ( host:ip => [ $backend, ... ] ); array of backends we have connected
our %ReproxyMax; # ( host:ip => int ); maximum number of connections to have open at any one time
our $ReproxyGlobalMax; # int; the global cap used if no per-host cap is specified
our $NoSpawn = 0; # bool; when set, spawn_backend immediately returns without running
our $LastCleanup = 0; # int; time we last ran our cleanup logic (FIXME: temp hack)
# singleton new function; returns us if we exist, else creates us
sub get {
return $ReproxySelf if $ReproxySelf;
# doesn't exist, so create it and return it
my $class = shift;
my $self = {};
bless $self, $class;
return $ReproxySelf = $self;
}
# given (clientproxy, primary_res_hdrs), initiate proceedings to process a
# request for a reproxy resource
sub do_reproxy {
my Perlbal::ReproxyManager $self = Perlbal::ReproxyManager->get; # singleton
my Perlbal::ClientProxy $cp = $_[0];
return undef unless $self && $cp;
# get data we use
my $datref = $cp->{reproxy_uris}->[0];
my $ipport = "$datref->[0]:$datref->[1]";
push @{$ReproxyQueues{$ipport} ||= []}, $cp;
# see if we should do cleanup (FIXME: temp hack)
my $now = time();
if ($LastCleanup < $now - 5) {
# remove closed backends from our array. this is O(n) but n is small
# and we're paranoid that just keeping a count would get corrupt over
# time. also removes the backends that have clients that are closed.
@{$ReproxyBackends{$ipport}} = grep {
! $_->{closed} && (! $_->{client} || ! $_->{client}->{closed})
} @{$ReproxyBackends{$ipport}};
$LastCleanup = $now;
}
# now start a new backend
$self->spawn_backend($ipport);
return 1;
}
# part of the reportto interface; this is called when a backend is unable to establish
# a connection with a backend. we simply try the next uri.
sub note_bad_backend_connect {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# decrement counts and undef connecting backend
$ReproxyConnecting{$be->{ipport}} = undef;
# if nobody waiting, doesn't matter if we couldn't get to this backend
return unless @{$ReproxyQueues{$be->{ipport}} || []};
# if we still have some connected backends then ignore this bad connection attempt
return if scalar @{$ReproxyBackends{$be->{ipport}} || []};
# at this point, we have no connected backends, and our connecting one failed
# so we want to tell all of the waiting clients to try their next uri, because
# this host is down.
while (my Perlbal::ClientProxy $cp = shift @{$ReproxyQueues{$be->{ipport}}}) {
$cp->try_next_uri;
}
return 1;
}
# called by a backend when it's ready for a request
sub register_boredom {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# if this backend was connecting
my $ipport = $be->{ipport};
if ($ReproxyConnecting{$ipport} && $ReproxyConnecting{$ipport} == $be) {
$ReproxyConnecting{$ipport} = undef;
$ReproxyBackends{$ipport} ||= [];
push @{$ReproxyBackends{$ipport}}, $be;
}
# sometimes a backend is closed but it tries to register with us anyway... ignore it
# but since this might have been our only one, spawn another
if ($be->{closed}) {
$self->spawn_backend($ipport);
return;
}
# find some clients to use
while (my Perlbal::ClientProxy $cp = shift @{$ReproxyQueues{$ipport} || []}) {
# safety checks
next if $cp->{closed};
# give backend to client
$cp->use_reproxy_backend($be);
return;
}
# no clients if we get here, so push onto bored backend list
push @{$ReproxyBored{$ipport} ||= []}, $be;
# clean up the front of our list if we can (see docs above)
if (my Perlbal::BackendHTTP $bbe = $ReproxyBored{$ipport}->[0]) {
if ($bbe->{alive_time} < time() - 5) {
$NoSpawn = 1;
$bbe->close('have_newer_bored');
shift @{$ReproxyBored{$ipport}};
$NoSpawn = 0;
}
}
return 0;
}
# backend closed, decrease counts, etc
sub note_backend_close {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# remove closed backends from our array. this is O(n) but n is small
# and we're paranoid that just keeping a count would get corrupt over
# time.
@{$ReproxyBackends{$be->{ipport}}} = grep {
! $_->{closed}
} @{$ReproxyBackends{$be->{ipport}}};
# spawn more if needed
$self->spawn_backend($be->{ipport});
}
sub spawn_backend {
return if $NoSpawn;
my Perlbal::ReproxyManager $self = $_[0];
my $ipport = $_[1];
# if we're already connecting, we don't want to spawn another one
if (my Perlbal::BackendHTTP $be = $ReproxyConnecting{$ipport}) {
# see if this one is too old?
if ($be->{create_time} < (time() - 5)) { # older than 5 seconds?
$self->note_bad_backend_connect($be);
$be->close("connection_timeout");
# we return here instead of spawning because closing the backend calls
# note_backend_close which will call spawn_backend again, and at that
# point we won't have a pending connection and can spawn
return;
} else {
# don't spawn more if we're already connecting
return;
}
}
# if nobody waiting, don't spawn extra connections
return unless @{$ReproxyQueues{$ipport} || []};
# don't spawn if we have a bored one already
while (my Perlbal::BackendHTTP $bbe = pop @{$ReproxyBored{$ipport} || []}) {
# don't use keep-alive connections if we know the server's
# just about to kill the connection for being idle
my $now = time();
if ($bbe->{disconnect_at} && $now + 2 > $bbe->{disconnect_at} ||
$bbe->{alive_time} < $now - 5)
{
$NoSpawn = 1;
$bbe->close("too_close_disconnect");
$NoSpawn = 0;
next;
}
# it's good, give it to someone
$self->register_boredom($bbe);
return;
}
# see if we have too many already?
my $max = $ReproxyMax{$ipport} || $ReproxyGlobalMax || 0;
my $count = scalar @{$ReproxyBackends{$ipport} || []};
return if $max && ($count >= $max);
# start one connecting and enqueue
my $be = Perlbal::BackendHTTP->new(undef, split(/:/, $ipport), { reportto => $self })
or return 0;
$ReproxyConnecting{$ipport} = $be;
}
sub backend_response_received {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
my Perlbal::ClientProxy $cp = $be->{client};
# if no client, close backend and return 1
unless ($cp) {
$be->close("lost_client");
return 1;
}
# pass on to client
return $cp->backend_response_received($be);
}
sub dump_state {
my $out = shift;
return unless $out;
# spits out what we have connecting
while (my ($hostip, $dat) = each %ReproxyConnecting) {
$out->("connecting $hostip 1") if defined $dat;
}
while (my ($hostip, $dat) = each %ReproxyBored) {
$out->("bored $hostip " . scalar(@$dat));
}
while (my ($hostip, $dat) = each %ReproxyQueues) {
$out->("clients_queued $hostip " . scalar(@$dat));
}
while (my ($hostip, $dat) = each %ReproxyBackends) {
$out->("backends $hostip " . scalar(@$dat));
foreach my $be (@$dat) {
$out->("... " . $be->as_string);
}
}
while (my ($hostip, $dat) = each %ReproxyMax) {
$out->("SERVER max_reproxy_connections($hostip) = $dat");
}
$out->("SERVER max_reproxy_connections = " . ($ReproxyGlobalMax || 0));
$out->('.');
}
1;

907
wcmtools/perlbal/lib/Perlbal/Service.pm Executable file
View File

@@ -0,0 +1,907 @@
######################################################################
# Service class
######################################################################
package Perlbal::Service;
use strict;
use warnings;
use Net::Netmask;
use Perlbal::BackendHTTP;
use fields (
'name',
'enabled', # bool
'role', # currently 'reverse_proxy' or 'management'
'listen', # scalar: "$ip:$port"
'pool', # Perlbal::Pool that we're using to allocate nodes if we're in proxy mode
'docroot', # document root for webserver role
'dirindexing', # bool: direcotry indexing? (for webserver role) not async.
'index_files', # arrayref of filenames to try for index files
'listener',
'waiting_clients', # arrayref of clients waiting for backendhttp conns
'waiting_clients_highpri', # arrayref of high-priority clients waiting for backendhttp conns
'waiting_client_count', # number of clients waiting for backendds
'waiting_client_map' , # map of clientproxy fd -> 1 (if they're waiting for a conn)
'pending_connects', # hashref of "ip:port" -> $time (only one pending connect to backend at a time)
'pending_connect_count', # number of outstanding backend connects
'high_priority_cookie', # cookie name to check if client can 'cut in line' and get backends faster
'high_priority_cookie_contents', # aforementioned cookie value must contain this substring
'connect_ahead', # scalar: number of spare backends to connect to in advance all the time
'backend_persist_cache', # scalar: max number of persistent backends to hold onto while no clients
'bored_backends', # arrayref of backends we've already connected to, but haven't got clients
'persist_client', # bool: persistent connections for clients
'persist_backend', # bool: persistent connections for backends
'verify_backend', # bool: get attention of backend before giving it clients (using OPTIONS)
'max_backend_uses', # max requests to send per kept-alive backend (default 0 = unlimited)
'hooks', # hashref: hookname => [ [ plugin, ref ], [ plugin, ref ], ... ]
'plugins', # hashref: name => 1
'plugin_order', # arrayref: name, name, name...
'plugin_setters', # hashref: { plugin_name => { key_name => coderef } }
'extra_config', # hashref: extra config options; name => values
'enable_put', # bool: whether PUT is supported
'max_put_size', # int: max size in bytes of a put file
'min_put_directory', # int: number of directories required to exist at beginning of URIs in put
'enable_delete', # bool: whether DELETE is supported
'buffer_size', # int: specifies how much data a ClientProxy object should buffer from a backend
'buffer_size_reproxy_url', # int: same as above but for backends that are reproxying for us
'spawn_lock', # bool: if true, we're currently in spawn_backends
'queue_relief_size', # int; number of outstanding standard priority
# connections to activate pressure relief at
'queue_relief_chance', # int:0-100; % chance to take a standard priority
# request when we're in pressure relief mode
'trusted_upstreams', # Net::Netmask object containing netmasks for trusted upstreams
'always_trusted', # bool; if true, always trust upstreams
'extra_headers', # { insert => [ [ header, value ], ... ], remove => [ header, header, ... ],
# set => [ [ header, value ], ... ] }; used in header management interface
'generation', # int; generation count so we can slough off backends from old pools
'backend_no_spawn', # { "ip:port" => 1 }; if on, spawn_backends will ignore this ip:port combo
'buffer_backend_connect', # 0 for of, else, number of bytes to buffer before we ask for a backend
);
sub new {
my Perlbal::Service $self = shift;
$self = fields::new($self) unless ref $self;
my ($name) = @_;
$self->{name} = $name;
$self->{enabled} = 0;
$self->{listen} = "";
$self->{persist_client} = 0;
$self->{persist_backend} = 0;
$self->{verify_backend} = 0;
$self->{max_backend_uses} = 0;
$self->{backend_persist_cache} = 2;
$self->{generation} = 0;
$self->{backend_no_spawn} = {};
$self->{buffer_backend_connect} = 0;
$self->{hooks} = {};
$self->{plugins} = {};
$self->{plugin_order} = [];
$self->{enable_put} = 0;
$self->{max_put_size} = 0; # 0 means no max size
$self->{min_put_directory} = 0;
$self->{enable_delete} = 0;
# disable pressure relief by default
$self->{queue_relief_size} = 0;
$self->{queue_relief_chance} = 0;
# set some default maximum buffer sizes
$self->{buffer_size} = 256_000;
$self->{buffer_size_reproxy_url} = 51_200;
# track pending connects to backend
$self->{pending_connects} = {};
$self->{pending_connect_count} = 0;
$self->{bored_backends} = [];
$self->{connect_ahead} = 0;
# waiting clients
$self->{waiting_clients} = [];
$self->{waiting_clients_highpri} = [];
$self->{waiting_client_count} = 0;
# directory handling
$self->{dirindexing} = 0;
$self->{index_files} = [ 'index.html' ];
# don't have an object for this yet
$self->{trusted_upstreams} = undef;
$self->{always_trusted} = 0;
# bare data structure for extra header info
$self->{extra_headers} = { remove => [], insert => [] };
return $self;
}
# run the hooks in a list one by one until one hook returns 1. returns
# 1 or 0 depending on if any hooks handled the request.
sub run_hook {
my Perlbal::Service $self = shift;
my $hook = shift;
if (defined (my $ref = $self->{hooks}->{$hook})) {
# call all the hooks until one returns true
foreach my $hookref (@$ref) {
my $rval = $hookref->[1]->(@_);
return 1 if defined $rval && $rval;
}
}
return 0;
}
# run a bunch of hooks in this service, always returns undef.
sub run_hooks {
my Perlbal::Service $self = shift;
my $hook = shift;
if (defined (my $ref = $self->{hooks}->{$hook})) {
# call all the hooks
$_->[1]->(@_) foreach @$ref;
}
return undef;
}
# define a hook for this service
sub register_hook {
my Perlbal::Service $self = shift;
my ($pclass, $hook, $ref) = @_;
push @{$self->{hooks}->{$hook} ||= []}, [ $pclass, $ref ];
return 1;
}
# remove hooks we have defined
sub unregister_hook {
my Perlbal::Service $self = shift;
my ($pclass, $hook) = @_;
if (defined (my $refs = $self->{hooks}->{$hook})) {
my @new;
foreach my $ref (@$refs) {
# fill @new with hooks that DON'T match
push @new, $ref
unless $ref->[0] eq $pclass;
}
$self->{hooks}->{$hook} = \@new;
return 1;
}
return undef;
}
# remove all hooks of a certain class
sub unregister_hooks {
my Perlbal::Service $self = shift;
foreach my $hook (keys %{$self->{hooks}}) {
# call unregister_hook with this hook name
$self->unregister_hook($_[0], $hook);
}
}
# register a value setter for plugin configuration
sub register_setter {
my Perlbal::Service $self = shift;
my ($pclass, $key, $coderef) = @_;
return unless $pclass && $key && $coderef;
$self->{plugin_setters}->{lc $pclass}->{lc $key} = $coderef;
}
# remove a setter
sub unregister_setter {
my Perlbal::Service $self = shift;
my ($pclass, $key) = @_;
return unless $pclass && $key;
delete $self->{plugin_setters}->{lc $pclass}->{lc $key};
}
# remove a bunch of setters
sub unregister_setters {
my Perlbal::Service $self = shift;
my $pclass = shift;
return unless $pclass;
delete $self->{plugin_setters}->{lc $pclass};
}
# take a backend we've created and mark it as pending if we do not
# have another pending backend connection in this slot
sub add_pending_connect {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
# error if we already have a pending connection for this ipport
if (defined $self->{pending_connects}{$be->{ipport}}) {
Perlbal::log('warning', "Warning: attempting to spawn backend connection that already existed.");
# now dump a backtrace so we know how we got here
my $depth = 0;
while (my ($package, $filename, $line, $subroutine) = caller($depth++)) {
Perlbal::log('warning', " -- [$filename:$line] $package::$subroutine");
}
# we're done now, just return
return;
}
# set this connection up in the pending connection list
$self->{pending_connects}{$be->{ipport}} = $be;
$self->{pending_connect_count}++;
}
# remove a backend connection from the pending connect list if and only
# if it is the actual connection contained in the list; prevent double
# decrementing on accident
sub clear_pending_connect {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
if (defined $self->{pending_connects}{$be->{ipport}} && defined $be &&
$self->{pending_connects}{$be->{ipport}} == $be) {
$self->{pending_connects}{$be->{ipport}} = undef;
$self->{pending_connect_count}--;
}
}
# called by BackendHTTP when it's closed by any means
sub note_backend_close {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
$self->clear_pending_connect($be);
$self->spawn_backends;
}
# called by ClientProxy when it dies.
sub note_client_close {
my Perlbal::Service $self;
my Perlbal::ClientProxy $cp;
($self, $cp) = @_;
if (delete $self->{waiting_client_map}{$cp->{fd}}) {
$self->{waiting_client_count}--;
}
}
sub mark_node_used {
my Perlbal::Service $self = $_[0];
$self->{pool}->mark_node_used($_[1]) if $self->{pool};
}
sub get_client {
my Perlbal::Service $self = shift;
my $ret = sub {
my Perlbal::ClientProxy $cp = shift;
$self->{waiting_client_count}--;
delete $self->{waiting_client_map}{$cp->{fd}};
# before we return, start another round of connections
$self->spawn_backends;
return $cp;
};
# determine if we should jump straight to the high priority queue or
# act as pressure relief on the standard queue
my $hp_first = 1;
if (($self->{queue_relief_size} > 0) &&
(scalar(@{$self->{waiting_clients}}) >= $self->{queue_relief_size})) {
# if we're below the chance level, take a standard queue item
$hp_first = 0
if rand(100) < $self->{queue_relief_chance};
}
# find a high-priority client, or a regular one
my Perlbal::ClientProxy $cp;
while ($hp_first && ($cp = shift @{$self->{waiting_clients_highpri}})) {
if (Perlbal::DEBUG >= 2) {
my $backlog = scalar @{$self->{waiting_clients}};
print "Got from fast queue, in front of $backlog others\n";
}
return $ret->($cp) if ! $cp->{closed};
}
while ($cp = shift @{$self->{waiting_clients}}) {
if (Perlbal::DEBUG >= 2) {
print "Backend requesting client, got normal = $cp->{fd}.\n" unless $cp->{closed};
}
return $ret->($cp) if ! $cp->{closed};
}
return undef;
}
# given a backend, verify it's generation
sub verify_generation {
my Perlbal::Service $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# fast cases: generation count matches, so we just return an 'okay!' flag
return 1 if $self->{generation} == $be->generation;
# if our current pool knows about this ip:port, then we can still use it
if (defined $self->{pool}->node_used($be->ipport)) {
# so we know this is good, in the future we just want to hit the fast case
# and continue, so let's update the generation
$be->generation($self->{generation});
return 1;
}
# if we get here, the backend should be closed
$be->close('invalid_generation');
return 0;
}
# called by backend connection after it becomes writable
sub register_boredom {
my Perlbal::Service $self;
my Perlbal::BackendHTTP $be;
($self, $be) = @_;
# note that this backend is no longer pending a connect,
# if we thought it was before. but not if it's a persistent
# connection asking to be re-used.
unless ($be->{use_count}) {
$self->clear_pending_connect($be);
}
# it is possible that this backend is part of a different pool that we're
# no longer using... if that's the case, we want to close it
return unless $self->verify_generation($be);
# now try to fetch a client for it
my Perlbal::ClientProxy $cp = $self->get_client;
if ($cp) {
if ($be->assign_client($cp)) {
return;
} else {
# don't want to lose client, so we (unfortunately)
# stick it at the end of the waiting queue.
# fortunately, assign_client shouldn't ever fail.
$self->request_backend_connection($cp);
}
}
# don't hang onto more bored, persistent connections than
# has been configured for connect-ahead
if ($be->{use_count}) {
my $current_bored = scalar @{$self->{bored_backends}};
if ($current_bored >= $self->{backend_persist_cache}) {
$be->close('too_many_bored');
return;
}
}
# put backends which are known to be bound to processes
# and not to TCP stacks at the beginning where they'll
# be used first
if ($be->{has_attention}) {
unshift @{$self->{bored_backends}}, $be;
} else {
push @{$self->{bored_backends}}, $be;
}
}
sub note_bad_backend_connect {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
my $retry_time = shift();
# clear this pending connection
$self->clear_pending_connect($be);
# mark this host as dead for a while if we need to
if (defined $retry_time && $retry_time > 0) {
# we don't want other spawn_backends calls to retry
$self->{backend_no_spawn}->{$be->{ipport}} = 1;
# and now we set a callback to ensure we're kicked at the right time
Perlbal::Socket::register_callback($retry_time, sub {
delete $self->{backend_no_spawn}->{$be->{ipport}};
$self->spawn_backends;
});
}
# FIXME: do something interesting (tell load balancer about dead host,
# and fire up a new connection, if warranted)
# makes a new connection, if needed
$self->spawn_backends;
}
sub request_backend_connection {
my Perlbal::Service $self;
my Perlbal::ClientProxy $cp;
($self, $cp) = @_;
my $hi_pri = 0; # by default, low priority
# is there a defined high-priority cookie?
if (my $cname = $self->{high_priority_cookie}) {
# decide what priority class this request is in
my $hd = $cp->{req_headers};
my %cookie;
foreach (split(/;\s+/, $hd->header("Cookie") || '')) {
next unless ($_ =~ /(.*)=(.*)/);
$cookie{_durl($1)} = _durl($2);
}
my $hicookie = $cookie{$cname} || "";
$hi_pri = index($hicookie, $self->{high_priority_cookie_contents}) != -1;
}
# now, call hook to see if this should be high priority
$hi_pri = $self->run_hook('make_high_priority', $cp)
unless $hi_pri; # only if it's not already
$cp->{high_priority} = 1 if $hi_pri;
# before we even consider spawning backends, let's see if we have
# some bored (pre-connected) backends that'd take this client
my Perlbal::BackendHTTP $be;
my $now = time;
while ($be = shift @{$self->{bored_backends}}) {
next if $be->{closed};
# now make sure that it's still in our pool, and if not, close it
next unless $self->verify_generation($be);
# don't use connect-ahead connections when we haven't
# verified we have their attention
if (! $be->{has_attention} && $be->{create_time} < $now - 5) {
$be->close("too_old_bored");
next;
}
# don't use keep-alive connections if we know the server's
# just about to kill the connection for being idle
if ($be->{disconnect_at} && $now + 2 > $be->{disconnect_at}) {
$be->close("too_close_disconnect");
next;
}
# give the backend this client
if ($be->assign_client($cp)) {
# and make some extra bored backends, if configured as such
$self->spawn_backends;
return;
}
}
if ($hi_pri) {
push @{$self->{waiting_clients_highpri}}, $cp;
} else {
push @{$self->{waiting_clients}}, $cp;
}
$self->{waiting_client_count}++;
$self->{waiting_client_map}{$cp->{fd}} = 1;
$self->spawn_backends;
}
# sees if it should spawn one or more backend connections
sub spawn_backends {
my Perlbal::Service $self = shift;
# to spawn we must have a pool
return unless $self->{pool};
# check our lock and set it if we can
return if $self->{spawn_lock};
$self->{spawn_lock} = 1;
# sanity checks on our bookkeeping
if ($self->{pending_connect_count} < 0) {
Perlbal::log('crit', "Bogus: service $self->{name} has pending connect ".
"count of $self->{pending_connect_count}?! Resetting.");
$self->{pending_connect_count} = scalar
map { $_ && ! $_->{closed} } values %{$self->{pending_connects}};
}
# keep track of the sum of existing_bored + bored_created
my $backends_created = scalar(@{$self->{bored_backends}}) + $self->{pending_connect_count};
my $backends_needed = $self->{waiting_client_count} + $self->{connect_ahead};
my $to_create = $backends_needed - $backends_created;
# can't create more than this, assuming one pending connect per node
my $max_creatable = $self->{pool}->node_count - $self->{pending_connect_count};
$to_create = $max_creatable if $to_create > $max_creatable;
# cap number of attempted connects at once
$to_create = 10 if $to_create > 10;
my $now = time;
while ($to_create > 0) {
$to_create--;
my ($ip, $port) = $self->{pool}->get_backend_endpoint;
unless ($ip) {
Perlbal::log('crit', "No backend IP for service $self->{name}");
# FIXME: register desperate flag, so load-balancer module can callback when it has a node
$self->{spawn_lock} = 0;
return;
}
# handle retry timeouts so we don't spin
next if $self->{backend_no_spawn}->{"$ip:$port"};
# if it's pending, verify the pending one is still valid
if (my Perlbal::BackendHTTP $be = $self->{pending_connects}{"$ip:$port"}) {
my $age = $now - $be->{create_time};
if ($age >= 5 && $be->{state} eq "connecting") {
$be->close('connect_timeout');
} elsif ($age >= 60 && $be->{state} eq "verifying_backend") {
# after 60 seconds of attempting to verify, we're probably already dead
$be->close('verify_timeout');
} elsif (! $be->{closed}) {
next;
}
}
# now actually spawn a backend and add it to our pending list
if (my $be = Perlbal::BackendHTTP->new($self, $ip, $port, { pool => $self->{pool},
generation => $self->{generation} })) {
$self->add_pending_connect($be);
}
}
# clear our spawn lock
$self->{spawn_lock} = 0;
}
# getter only
sub role {
my Perlbal::Service $self = shift;
return $self->{role};
}
# manage some header stuff
sub header_management {
my Perlbal::Service $self = shift;
my ($mode, $key, $val, $out) = @_;
my $err = sub { $out->("ERROR: $_[0]"); return 0; };
return $err->("no header provided") unless $key;
return $err->("no value provided") unless $val || $mode eq 'remove';
if ($mode eq 'insert') {
push @{$self->{extra_headers}->{insert}}, [ $key, $val ];
} elsif ($mode eq 'remove') {
push @{$self->{extra_headers}->{remove}}, $key;
} else {
return $err->("invalid mode '$mode'");
}
return 1;
}
sub munge_headers {
my Perlbal::Service $self = $_[0];
my Perlbal::HTTPHeaders $hdrs = $_[1];
# handle removals first
foreach my $hdr (@{$self->{extra_headers}->{remove}}) {
$hdrs->header($hdr, undef);
}
# and now insertions
foreach my $hdr (@{$self->{extra_headers}->{insert}}) {
$hdrs->header($hdr->[0], $hdr->[1]);
}
}
# Service
sub set {
my Perlbal::Service $self = shift;
my ($key, $val, $out, $verbose) = @_;
my $err = sub { $out->("ERROR: $_[0]"); return 0; };
my $ok = sub { $out->("OK") if $verbose; return 1; };
my $set = sub { $self->{$key} = $val; return $ok->(); };
my $pool_set = sub {
# if we don't have a pool, automatically create one named $NAME_pool
unless ($self->{pool}) {
# die if necessary
die "ERROR: Attempt to vivify pool $self->{name}_pool but one or more pools\n" .
" have already been created manually. Please set $key on a\n" .
" previously created pool.\n" unless $Perlbal::vivify_pools;
# create the pool and ensure that vivify stays on
Perlbal::run_manage_command("CREATE POOL $self->{name}_pool", $out);
Perlbal::run_manage_command("SET $self->{name}.pool = $self->{name}_pool");
$Perlbal::vivify_pools = 1;
}
# now we actually do the set
warn "WARNING: '$key' set on service $self->{name} on auto-vivified pool.\n" .
" This behavior is obsolete. This value should be set on a\n" .
" pool object and not on a service.\n" if $Perlbal::vivify_pools;
return $err->("No pool defined for service") unless $self->{pool};
return $self->{pool}->set($key, $val, $out, $verbose);
};
if ($key eq "role") {
return $err->("Unknown service role")
unless $val eq "reverse_proxy" || $val eq "management" || $val eq "web_server";
return $set->();
}
if ($key eq "listen") {
return $err->("Invalid host:port")
unless $val =~ m!^\d+\.\d+\.\d+\.\d+:\d+$!;
# close/reopen listening socket
if ($val ne $self->{listen} && $self->{enabled}) {
$self->disable(undef, "force");
$self->{listen} = $val;
$self->enable(undef);
}
return $set->();
}
my $bool = sub {
my $val = shift;
return 1 if $val =~ /^1|true|on|yes$/i;
return 0 if $val =~ /^0|false|off|no$/i;
return undef;
};
if ($key eq 'trusted_upstream_proxies') {
if ($self->{trusted_upstreams} = Net::Netmask->new2($val)) {
# set, all good
return $ok->();
} else {
return $err->("Error defining trusted upstream proxies: " . Net::Netmask::errstr());
}
}
if ($key eq 'always_trusted') {
$val = $bool->($val);
return $err->("Expecting boolean value for option '$key'")
unless defined $val;
return $set->();
}
if ($key eq 'enable_put' || $key eq 'enable_delete') {
return $err->("This can only be used on web_server service")
unless $self->{role} eq 'web_server';
$val = $bool->($val);
return $err->("Expecting boolean value for option '$key'.")
unless defined $val;
return $set->();
}
if ($key eq "persist_client" || $key eq "persist_backend" ||
$key eq "verify_backend") {
$val = $bool->($val);
return $err->("Expecting boolean value for option '$key'")
unless defined $val;
return $set->();
}
# this is now handled by Perlbal::Pool, so we pass this set command on
# through in case people try to use it on us like the old method.
return $pool_set->()
if $key eq 'balance_method' ||
$key eq 'nodefile' ||
$key =~ /^sendstats\./;
if ($key eq "balance_method") {
return $err->("Can only set balance method on a reverse_proxy service")
unless $self->{role} eq "reverse_proxy";
}
if ($key eq "high_priority_cookie" || $key eq "high_priority_cookie_contents") {
return $set->();
}
if ($key eq "connect_ahead") {
return $err->("Expected integer value") unless $val =~ /^\d+$/;
$set->();
$self->spawn_backends if $self->{enabled};
return $ok->();
}
if ($key eq "max_backend_uses" || $key eq "backend_persist_cache" ||
$key eq "max_put_size" || $key eq "min_put_directory" ||
$key eq "buffer_size" || $key eq "buffer_size_reproxy_url" ||
$key eq "queue_relief_size" || $key eq "buffer_backend_connect") {
return $err->("Expected integer value") unless $val =~ /^\d+$/;
return $set->();
}
if ($key eq "queue_relief_chance") {
return $err->("Expected integer value") unless $val =~ /^\d+$/;
return $err->("Expected integer value between 0 and 100 inclusive")
unless $val >= 0 && $val <= 100;
return $set->();
}
if ($key eq "docroot") {
return $err->("Can only set docroot on a web_server service")
unless $self->{role} eq "web_server";
$val =~ s!/$!!;
return $err->("Directory not found")
unless $val && -d $val;
return $set->();
}
if ($key eq "dirindexing") {
return $err->("Can only set dirindexing on a web_server service")
unless $self->{role} eq "web_server";
return $err->("Expected value 0 or 1")
unless $val eq '0' || $val eq '1';
return $set->();
}
if ($key eq "index_files") {
return $err->("Can only set index_files on a web_server service")
unless $self->{role} eq "web_server";
my @list = split(/[\s,]+/, $val);
$self->{index_files} = \@list;
return $ok->();
}
if ($key eq 'plugins') {
# unload existing plugins
foreach my $plugin (keys %{$self->{plugins}}) {
eval "Perlbal::Plugin::$plugin->unregister(\$self);";
return $err->($@) if $@;
}
# clear out loaded plugins and hooks
$self->{hooks} = {};
$self->{plugins} = {};
$self->{plugin_order} = [];
# load some plugins
foreach my $plugin (split /[\s,]+/, $val) {
next if $plugin eq 'none';
# since we lowercase our input, uppercase the first character here
my $fn = uc($1) . lc($2) if $plugin =~ /^(.)(.*)$/;
next if $self->{plugins}->{$fn};
unless ($Perlbal::plugins{$fn}) {
$err->("Plugin $fn not loaded; not registered for $self->{name}.");
next;
}
# now register it
eval "Perlbal::Plugin::$fn->register(\$self);";
$self->{plugins}->{$fn} = 1;
push @{$self->{plugin_order}}, $fn;
return $err->($@) if $@;
}
return $ok->();
}
if ($key =~ /^extra\.(.+)$/) {
# set some extra configuration data data
$self->{extra_config}->{$1} = $val;
return $ok->();
}
if ($key eq 'pool') {
my $pl = Perlbal->pool($val);
return $err->("Pool '$val' not found") unless $pl;
$self->{pool}->decrement_use_count if $self->{pool};
$self->{pool} = $pl;
$self->{pool}->increment_use_count;
$self->{generation}++;
return $ok->();
}
# see if it happens to be a plugin set command?
if ($key =~ /^(.+)\.(.+)$/) {
if (my $coderef = $self->{plugin_setters}->{$1}->{$2}) {
return $coderef->($out, $2, $val);
}
}
return $err->("Unknown attribute '$key'");
}
# Service
sub enable {
my Perlbal::Service $self;
my $out;
($self, $out) = @_;
if ($self->{enabled}) {
$out && $out->("ERROR: service $self->{name} is already enabled");
return 0;
}
# create listening socket
my $tl = Perlbal::TCPListener->new($self->{listen}, $self);
unless ($tl) {
$out && $out->("ERROR: Can't start service '$self->{name}' on $self->{listen}: $Perlbal::last_error");
return 0;
}
$self->{listener} = $tl;
$self->{enabled} = 1;
return 1;
}
# Service
sub disable {
my Perlbal::Service $self;
my ($out, $force);
($self, $out, $force) = @_;
if (! $self->{enabled}) {
$out && $out->("ERROR: service $self->{name} is already disabled");
return 0;
}
if ($self->{role} eq "management" && ! $force) {
$out && $out->("ERROR: can't disable management service");
return 0;
}
# find listening socket
my $tl = $self->{listener};
$tl->close;
$self->{listener} = undef;
$self->{enabled} = 0;
return 1;
}
sub stats_info
{
my Perlbal::Service $self = shift;
my $out = shift;
my $now = time;
$out->("SERVICE $self->{name}");
$out->(" listening: $self->{listen}");
$out->(" role: $self->{role}");
if ($self->{role} eq "reverse_proxy" ||
$self->{role} eq "web_server") {
$out->(" pend clients: $self->{waiting_client_count}");
$out->(" pend backend: $self->{pending_connect_count}");
foreach my $ipport (sort keys %{$self->{pending_connects}}) {
my $be = $self->{pending_connects}{$ipport};
next unless $be;
my $age = $now - $be->{create_time};
$out->(" $ipport - " . ($be->{closed} ? "(closed)" : $be->{state}) . " - ${age}s");
}
}
if ($self->{role} eq "reverse_proxy") {
my $bored_count = scalar @{$self->{bored_backends}};
$out->(" connect-ahead: $bored_count/$self->{connect_ahead}");
if ($self->{pool}) {
$out->(" pool: " . $self->{pool}->name);
$out->("balance method: " . $self->{pool}->balance_method);
$out->(" nodes:");
foreach my $n (@{ $self->{pool}->nodes }) {
my $hostport = "$n->[0]:$n->[1]";
$out->(sprintf(" %-21s %7d", $hostport, $self->{pool}->node_used($hostport) || 0));
}
}
} elsif ($self->{role} eq "web_server") {
$out->(" docroot: $self->{docroot}");
}
}
# simple passthroughs to the run_hook mechanism. part of the reportto interface.
sub backend_response_received {
return $_[0]->run_hook('backend_response_received', $_[1]);
}
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:

279
wcmtools/perlbal/lib/Perlbal/Socket.pm Executable file
View File

@@ -0,0 +1,279 @@
######################################################################
# Base class for all socket types
######################################################################
package Perlbal::Socket;
use strict;
use warnings;
use Perlbal::HTTPHeaders;
use Danga::Socket '1.25';
use base 'Danga::Socket';
use fields (
'headers_string', # headers as they're being read
'req_headers', # the final Perlbal::HTTPHeaders object inbound
'res_headers', # response headers outbound (Perlbal::HTTPHeaders object)
'create_time', # creation time
'alive_time', # last time noted alive
'state', # general purpose state; used by descendants.
'do_die', # if on, die and do no further requests
'read_buf',
'read_ahead',
'read_size',
);
use constant MAX_HTTP_HEADER_LENGTH => 102400; # 100k, arbitrary
use constant TRACK_OBJECTS => 0; # see @created_objects below
if (TRACK_OBJECTS) {
use Scalar::Util qw(weaken isweak);
}
# time we last did a full connection sweep (O(n) .. lame)
# and closed idle connections.
our $last_cleanup = 0;
our %state_changes = (); # { "objref" => [ state, state, state, ... ] }
our $last_callbacks = 0; # time last ran callbacks
our $callbacks = []; # [ [ time, subref ], [ time, subref ], ... ]
# this one deserves its own section. we keep track of every Perlbal::Socket object
# created if the TRACK_OBJECTS constant is on. we use weakened references, though,
# so this list will hopefully contain mostly undefs. users can ask for this list if
# they want to work with it via the get_created_objects_ref function.
our @created_objects; # ( $ref, $ref, $ref ... )
our $last_co_cleanup = 0; # clean the list every few seconds
sub get_statechange_ref {
return \%state_changes;
}
sub get_created_objects_ref {
return \@created_objects;
}
sub new {
my Perlbal::Socket $self = shift;
$self = fields::new( $self ) unless ref $self;
Perlbal::objctor($self);
$self->SUPER::new( @_ );
$self->{headers_string} = '';
$self->{state} = undef;
$self->{do_die} = 0;
my $now = time;
$self->{alive_time} = $self->{create_time} = $now;
# see if it's time to do a cleanup
# FIXME: constant time interval is lame. on pressure/idle?
if ($now - 15 > $last_cleanup) {
$last_cleanup = $now;
_do_cleanup();
}
# now put this item in the list of created objects
if (TRACK_OBJECTS) {
# clean the created objects list if necessary
if ($last_co_cleanup < $now - 5) {
# remove out undefs, because those are natural byproducts of weakening
# references
@created_objects = grep { $_ } @created_objects;
# however, the grep turned our weak references back into strong ones, so
# we have to reweaken them
weaken($_) foreach @created_objects;
# we've cleaned up at this point
$last_co_cleanup = $now;
}
# now add this one to our cleaned list and weaken it
push @created_objects, $self;
weaken($created_objects[-1]);
}
return $self;
}
# FIXME: this doesn't scale in theory, but it might use less CPU in
# practice than using the Heap:: modules and manipulating the
# expirations all the time, thus doing things properly
# algorithmically. and this is definitely less work, so it's worth
# a try.
sub _do_cleanup {
my $sf = Perlbal::Socket->get_sock_ref;
my $now = time;
my %max_age; # classname -> max age (0 means forever)
my @to_close;
while (my $k = each %$sf) {
my Perlbal::Socket $v = $sf->{$k};
my $ref = ref $v;
unless (defined $max_age{$ref}) {
$max_age{$ref} = $ref->max_idle_time || 0;
}
next unless $max_age{$ref};
if ($v->{alive_time} < $now - $max_age{$ref}) {
push @to_close, $v;
}
}
$_->close("perlbal_timeout") foreach @to_close;
}
# CLASS METHOD: given a delay (in seconds) and a subref, this will call
# that subref in AT LEAST delay seconds. if the subref returns 0, the
# callback is discarded, but if it returns a positive number, the callback
# is pushed onto the callback stack to be called again in at least that
# many seconds.
sub register_callback {
# adds a new callback to our list
my ($delay, $subref) = @_;
push @$callbacks, [ time + $delay, $subref ];
return 1;
}
# CLASS METHOD: runs through the list of registered callbacks and executes
# any that need to be executed
# FIXME: this doesn't scale. need a heap.
sub run_callbacks {
my $now = time;
return if $last_callbacks == $now;
$last_callbacks = $now;
my @destlist = ();
foreach my $ref (@$callbacks) {
# if their time is <= now...
if ($ref->[0] <= $now) {
# find out if they want to run again...
my $rv = $ref->[1]->();
# and if they do, push onto list...
push @destlist, [ $rv + $now, $ref->[1] ]
if defined $rv && $rv > 0;
} else {
# not time for this one, just shove it
push @destlist, $ref;
}
}
$callbacks = \@destlist;
}
# CLASS METHOD:
# default is for sockets to never time out. classes
# can override.
sub max_idle_time { 0; }
# Socket: specific to HTTP socket types
sub read_headers {
my Perlbal::Socket $self = shift;
my $is_res = shift;
$Perlbal::reqs++ unless $is_res;
my $sock = $self->{sock};
my $to_read = MAX_HTTP_HEADER_LENGTH - length($self->{headers_string});
my $bref = $self->read($to_read);
return $self->close('remote_closure') if ! defined $bref; # client disconnected
$self->{headers_string} .= $$bref;
my $idx = index($self->{headers_string}, "\r\n\r\n");
# can't find the header delimiter?
if ($idx == -1) {
$self->close('long_headers')
if length($self->{headers_string}) >= MAX_HTTP_HEADER_LENGTH;
return 0;
}
my $hstr = substr($self->{headers_string}, 0, $idx);
print "HEADERS: [$hstr]\n" if Perlbal::DEBUG >= 2;
my $extra = substr($self->{headers_string}, $idx+4);
if (my $len = length($extra)) {
push @{$self->{read_buf}}, \$extra;
$self->{read_size} = $self->{read_ahead} = length($extra);
print "post-header extra: $len bytes\n" if Perlbal::DEBUG >= 2;
}
unless (($is_res ? $self->{res_headers} : $self->{req_headers}) =
Perlbal::HTTPHeaders->new(\$hstr, $is_res)) {
# bogus headers? close connection.
return $self->close("parse_header_failure");
}
return $is_res ? $self->{res_headers} : $self->{req_headers};
}
### METHOD: drain_read_buf_to( $destination )
### Write read-buffered data (if any) from the receiving object to the
### I<destination> object.
sub drain_read_buf_to {
my ($self, $dest) = @_;
return unless $self->{read_ahead};
while (my $bref = shift @{$self->{read_buf}}) {
$dest->write($bref);
$self->{read_ahead} -= length($$bref);
}
}
### METHOD: die_gracefully()
### By default, if we're in persist_wait state, close. Else, ignore. Children
### can override if they want to do some other processing.
sub die_gracefully {
my Perlbal::Socket $self = $_[0];
if ($self->state eq 'persist_wait') {
$self->close('graceful_shutdown');
}
$self->{do_die} = 1;
}
### METHOD: close()
### Set our state when we get closed.
sub close {
my Perlbal::Socket $self = $_[0];
$self->state('closed');
return $self->SUPER::close($_[1]);
}
### METHOD: state()
### If you pass a parameter, sets the state, else returns it.
sub state {
my Perlbal::Socket $self = shift;
return $self->{state} unless @_;
push @{$state_changes{"$self"} ||= []}, $_[0] if Perlbal::TRACK_STATES;
return $self->{state} = $_[0];
}
sub read_request_headers { read_headers(@_, 0); }
sub read_response_headers { read_headers(@_, 1); }
sub as_string_html {
my Perlbal::Socket $self = shift;
return $self->SUPER::as_string;
}
sub DESTROY {
my Perlbal::Socket $self = shift;
delete $state_changes{"$self"} if Perlbal::TRACK_STATES;
Perlbal::objdtor($self);
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

219
wcmtools/perlbal/lib/Perlbal/StatsListener.pm Executable file
View File

@@ -0,0 +1,219 @@
######################################################################
# UDP listener for Apache free/busy stats
######################################################################
package Perlbal::StatsListener;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields ('service', # Perlbal::Service,
'pos', # index in ring. this index has an empty value in it
# entries before it are good
'message_ring', # arrayref of UDP messages, unparsed
'from_ring', # arrayref of from addresses
'hostinfo', # hashref of ip (4 bytes) -> [ $free, $active ] (or undef)
'total_free', # int scalar: free listeners
'need_parse', # hashref: ip -> pos
'use_count', # hashref: ip -> times_used (ip can also be '' for empty case)
'use_total', # int scalar: count of uses we've had total
'dead', # int; if 1 then we're dead (don't give out any more info)
);
use constant RING_SIZE => 30;
sub new {
my $class = shift;
my ($hostport, $service) = @_;
my $sock = IO::Socket::INET->new(
LocalAddr => $hostport,
Proto => 'udp',
ReuseAddr => 1,
Blocking => 0,
);
return Perlbal::error("Error creating listening socket: $!")
unless $sock;
$sock->sockopt(Socket::SO_BROADCAST, 1);
$sock->blocking(0);
my $self = fields::new($class);
$self->SUPER::new($sock); # init base fields
$self->{dead} = 0;
$self->{service} = $service;
$self->reset_state;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
sub reset_state {
my Perlbal::StatsListener $self = shift;
$self->{pos} = 0;
$self->{message_ring} = [];
$self->{from_ring} = [];
$self->{total_free} = 0;
$self->{need_parse} = {};
$self->{hostinfo} = {};
$self->{use_count} = {};
}
sub event_read {
my Perlbal::StatsListener $self = shift;
my $sock = $self->{sock};
my ($port, $iaddr);
while (my $from = $sock->recv($self->{message_ring}[$self->{pos}], 1024)) {
# set the from just to the 4 byte IP address
($port, $from) = Socket::sockaddr_in($from);
$self->{from_ring}[$self->{pos}] = $from;
# new message from host $from, so clear its cached data
if (exists $self->{hostinfo}{$from}) {
if (my $hi = $self->{hostinfo}{$from}) {
$self->{total_free} -= $hi->[0];
}
$self->{hostinfo}{$from} = undef;
$self->{need_parse}{$from} = $self->{pos};
}
$self->{pos} = 0 if ++$self->{pos} == RING_SIZE;
}
}
sub get_endpoint {
my Perlbal::StatsListener $self = shift;
return () if $self->{dead};
# catch up on our parsing
while (my ($from, $pos) = each %{$self->{need_parse}}) {
# make sure this position still corresponds to that host
next unless $from eq $self->{from_ring}[$pos];
next unless $self->{message_ring}[$pos] =~
m!^bcast_ver=1\nfree=(\d+)\nactive=(\d+)\n$!;
$self->{hostinfo}{$from} = [ $1, $2 ];
$self->{total_free} += $1;
}
$self->{need_parse} = {};
# mode 1 (normal) is on advertised free, mode 2 is when nothing's
# free, so we make a weighted random guess on past performance
my $mode = 1;
my $upper_bound = $self->{total_free};
unless ($upper_bound) {
$mode = 2;
$upper_bound = $self->{use_total};
}
# pick what position we'll return
my $winner = rand($upper_bound);
# find the winner
my $count = 0;
# two passes, since the inner while is doing 'each'
# which we intrerupt when we find the winner. so later,
# coming back into this, the each doesn't necessarily
# start in the beginning so we have to let it loop around
foreach my $pass (1..2) {
while (my ($from, $hi) = each %{$self->{hostinfo}}) {
if ($mode == 1) {
# must have data
next unless $hi;
$count += $hi->[0];
} elsif ($mode == 2) {
# increment count by uses this one's received for weighting
$count += $self->{use_count}{$from};
}
if ($count >= $winner) {
my $ip = Socket::inet_ntoa($from);
if ($mode == 1) {
$hi->[0]--;
$self->{total_free}--;
$self->{use_total}++;
$self->{use_count}{$from}++;
}
return ($ip, 80);
}
}
}
# guess we couldn't find anything
$self->{use_count}{'winner_too_high'}++;
return ();
}
sub set_hosts {
my Perlbal::StatsListener $self = shift;
my @hosts = @_;
# clear the known hosts
$self->reset_state;
# make each provided host known, but undef (meaning
# its ring data hasn't been parsed)
foreach my $dq (@hosts) {
# converted dotted quad to packed format
my $pd = Socket::inet_aton($dq);
$self->{hostinfo}{$pd} = undef;
}
}
sub debug_dump {
my Perlbal::StatsListener $self = shift;
my $out = shift;
no warnings;
$out->("Stats listener dump:");
$out->(" pos = $self->{pos}");
$out->(" message_ring = ");
for (my $i=0; $i<RING_SIZE; $i++) {
my $ip = eval { Socket::inet_ntoa($self->{'from_ring'}[$i]); };
$out->(" \#$i: [$ip] " . $self->{'message_ring'}[$i]);
}
my $count_free = 0;
foreach my $host (sort keys %{$self->{hostinfo}}) {
my $ip = eval { Socket::inet_ntoa($host); };
my $hi = $self->{hostinfo}{$host};
my $need_parse = $self->{need_parse}{$host};
my $uses = $self->{use_count}{$host};
if ($hi) {
$count_free += $hi->[0];
$out->(" host $ip = $uses: [ $hi->[0] free, $hi->[1] act ] needparse=$need_parse");
} else {
$out->(" host $ip = $uses: needparse=$need_parse");
}
}
$out->(" total free: $self->{total_free} (calculated: $count_free)");
$out->("Uses with no total: $self->{use_count}{'no_free'}, winner too high: $self->{use_count}{'winner_too_high'}");
}
sub event_err { }
sub event_hup { }
sub die_gracefully {
# okay, let's actually die now
my $self = shift;
$self->{dead} = 1;
$self->close;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

95
wcmtools/perlbal/lib/Perlbal/TCPListener.pm Executable file
View File

@@ -0,0 +1,95 @@
######################################################################
# TCP listener on a given port
######################################################################
package Perlbal::TCPListener;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields qw(service hostport);
use Socket qw(IPPROTO_TCP);
# TCPListener
sub new {
my ($class, $hostport, $service) = @_;
my $sock = IO::Socket::INET->new(
LocalAddr => $hostport,
Proto => IPPROTO_TCP,
Listen => 1024,
ReuseAddr => 1,
Blocking => 0,
);
return Perlbal::error("Error creating listening socket: $!")
unless $sock;
# IO::Socket::INET's Blocking => 0 just doesn't seem to work
# on lots of perls. who knows why.
IO::Handle::blocking($sock, 0);
my $self = $class->SUPER::new($sock);
$self->{service} = $service;
$self->{hostport} = $hostport;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
# TCPListener: accepts a new client connection
sub event_read {
my Perlbal::TCPListener $self = shift;
# accept as many connections as we can
while (my ($psock, $peeraddr) = $self->{sock}->accept) {
my $service_role = $self->{service}->role;
if (Perlbal::DEBUG >= 1) {
my ($pport, $pipr) = Socket::sockaddr_in($peeraddr);
my $pip = Socket::inet_ntoa($pipr);
print "Got new conn: $psock ($pip:$pport) for $service_role\n";
}
IO::Handle::blocking($psock, 0);
if ($service_role eq "reverse_proxy") {
Perlbal::ClientProxy->new($self->{service}, $psock);
} elsif ($service_role eq "management") {
Perlbal::ClientManage->new($self->{service}, $psock);
} elsif ($service_role eq "web_server") {
Perlbal::ClientHTTP->new($self->{service}, $psock);
}
}
}
sub as_string {
my Perlbal::TCPListener $self = shift;
my $ret = $self->SUPER::as_string;
my Perlbal::Service $svc = $self->{service};
$ret .= ": listening on $self->{hostport} for service '$svc->{name}'";
return $ret;
}
sub as_string_html {
my Perlbal::TCPListener $self = shift;
my $ret = $self->SUPER::as_string_html;
my Perlbal::Service $svc = $self->{service};
$ret .= ": listening on $self->{hostport} for service <b>$svc->{name}</b>";
return $ret;
}
sub die_gracefully {
# die off so we stop waiting for new connections
my $self = shift;
$self->close('graceful_death');
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

134
wcmtools/perlbal/lib/Perlbal/Test.pm Executable file
View File

@@ -0,0 +1,134 @@
package Perlbal::Test;
use strict;
use POSIX qw( :sys_wait_h );
use IO::Socket::INET;
require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(ua start_server foreach_aio manage filecontent tempdir new_port
wait_on_child);
our $i_am_parent = 0;
our $msock; # management sock of child
our $to_kill = 0;
our $mgmt_port;
our $free_port = 60000;
END {
manage("shutdown") if $i_am_parent;
}
sub tempdir {
require File::Temp;
return File::Temp::tempdir( CLEANUP => 1 );
}
sub new_port {
return $free_port++; # FIXME: make it somehow detect if port is in use?
}
sub filecontent {
my $file = shift;
my $ct;
open (F, $file) or return undef;
$ct = do { local $/; <F>; };
close F;
return $ct;
}
sub foreach_aio (&) {
my $cb = shift;
foreach my $mode (qw(none linux ioaio)) {
my $line = manage("SERVER aio_mode = $mode");
next unless $line;
$cb->($mode);
}
}
sub manage {
my $cmd = shift;
print $msock "$cmd\r\n";
my $res = <$msock>;
return 0 if !$res || $res =~ /^ERR/;
return $res;
}
sub start_server {
my $conf = shift;
$mgmt_port = new_port();
my $child = fork;
if ($child) {
$i_am_parent = 1;
$to_kill = $child;
my $msock = wait_on_child($child, $mgmt_port);
my $rv = waitpid($child, WNOHANG);
if ($rv) {
die "Child process (webserver) died.\n";
}
print $msock "proc\r\n";
my $spid = undef;
while (<$msock>) {
last if m!^\.\r?\n!;
next unless /^pid:\s+(\d+)/;
$spid = $1;
}
die "Our child was $child, but we connected and it says it's $spid."
unless $child == $spid;
return $msock;
}
# child process...
require Perlbal;
$conf .= qq{
CREATE SERVICE mgmt
SET mgmt.listen = 127.0.0.1:$mgmt_port
SET mgmt.role = management
ENABLE mgmt
};
my $out = sub { print STDOUT join("\n", map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_) . "\n"; };
Perlbal::run_manage_command($_, $out) foreach split(/\n/, $conf);
unless (Perlbal::Socket->WatchedSockets() > 0) {
die "Invalid configuration. (shouldn't happen?) Stopping (self=$$).\n";
}
Perlbal::run();
exit 0;
}
# get the manager socket
sub msock {
return $msock;
}
sub ua {
require LWP;
require LWP::UserAgent;
return LWP::UserAgent->new;
}
sub wait_on_child {
my $pid = shift;
my $port = shift;
my $start = time;
while (1) {
$msock = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
return $msock if $msock;
select undef, undef, undef, 0.25;
if (waitpid($pid, WNOHANG) > 0) {
die "Child process (webserver) died.\n";
}
die "Timeout waiting for port $port to startup" if time > $start + 5;
}
}
1;

127
wcmtools/perlbal/lib/Perlbal/Test/WebClient.pm Executable file
View File

@@ -0,0 +1,127 @@
#!/usr/bin/perl
package Perlbal::Test::WebClient;
use strict;
use IO::Socket::INET;
use HTTP::Response;
use Socket qw(MSG_NOSIGNAL);
require Exporter;
use vars qw(@ISA @EXPORT $FLAG_NOSIGNAL);
@ISA = qw(Exporter);
@EXPORT = qw(new);
eval { $FLAG_NOSIGNAL = MSG_NOSIGNAL; };
# create a blank object
sub new {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
# get/set what server we should be testing; "ip:port" generally
sub server {
my $self = shift;
if (@_) {
return $self->{server} = shift;
} else {
return $self->{server};
}
}
# set which HTTP version to emulate; specify '1.0' or '1.1'
sub http_version {
my $self = shift;
if (@_) {
return $self->{http_version} = shift;
} else {
return $self->{http_version};
}
}
# set on or off to enable or disable persistent connection
sub keepalive {
my $self = shift;
if (@_) {
$self->{keepalive} = shift() ? 1 : 0;
}
return $self->{keepalive};
}
# construct and send a request
sub request {
my $self = shift;
return undef unless $self->{server};
my $cmds = join(',', map { eurl($_) } @_);
return undef unless $cmds;
# keep-alive header if 1.0, also means add content-length header
my $headers = '';
$headers .= "Connection: keep-alive\r\n"
if $self->{keepalive};
my $send = "GET /$cmds HTTP/$self->{http_version}\r\n$headers\r\n";
my $len = length $send;
# send setup
my $rv;
my $sock = $self->{_sock};
local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
### send it cached
if ($sock) {
$rv = send($sock, $send, $FLAG_NOSIGNAL);
if ($! || ! defined $rv) {
undef $self->{_sock};
} elsif ($rv != $len) {
return undef;
}
}
# failing that, send it through a new socket
unless ($rv) {
$sock = IO::Socket::INET->new(
PeerAddr => $self->{server},
Timeout => 3,
) or return undef;
$rv = send($sock, $send, $FLAG_NOSIGNAL);
if ($! || $rv != $len) {
return undef;
}
$self->{_sock} = $sock
if $self->{keepalive};
}
my $res = '';
while (<$sock>) {
$res .= $_;
last if ! $_ || /^\r?\n/;
}
my $resp = HTTP::Response->parse($res);
return undef unless $resp;
my $cl = $resp->header('Content-Length');
if ($cl > 0) {
my $content = '';
while (($cl -= read($sock, $content, $cl)) > 0) {
# don't do anything, the loop is it
}
$resp->content($content);
}
return $resp;
}
# general purpose URL escaping function
sub eurl {
my $a = $_[0];
$a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
$a =~ tr/ /+/;
return $a;
}
1;

114
wcmtools/perlbal/lib/Perlbal/Test/WebServer.pm Executable file
View File

@@ -0,0 +1,114 @@
#!/usr/bin/perl
package Perlbal::Test::WebServer;
use strict;
use IO::Socket::INET;
use HTTP::Request;
use Perlbal::Test;
require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(start_webserver);
our @webserver_pids;
END {
# ensure we kill off the webserver
kill 9, @webserver_pids;
}
sub start_webserver {
my $port = new_port();
if (my $child = fork) {
# i am parent, wait for child to startup
push @webserver_pids, $child;
my $sock = wait_on_child($child, $port);
die "Unable to spawn webserver on port $port\n"
unless $sock;
print $sock "GET /status HTTP/1.0\r\n\r\n";
my $line = <$sock>;
die "Didn't get 200 OK: $line"
unless $line =~ /200 OK/;
return $port;
}
# i am child, start up
my $ssock = IO::Socket::INET->new(LocalPort => $port, ReuseAddr => 1, Listen => 3)
or die "Unable to start socket: $!\n";
while (my $csock = $ssock->accept) {
exit 0 unless $csock;
fork and next; # parent starts waiting for next request
my $response = sub {
my ($code, $msg, $content, $ctype) = @_;
$msg ||= { 200 => 'OK', 500 => 'Internal Server Error' }->{$code};
$content ||= "$code $msg";
my $clen = length $content;
$ctype ||= "text/plain";
return "HTTP/1.0 $code $msg\r\n" .
"Content-Type: $ctype\r\n" .
"Content-Length: $clen\r\n" .
"\r\n" .
"$content";
};
my $req = '';
while (<$csock>) {
$req .= $_;
last if ! $_ || /^\r?\n/;
}
# parse out things we want to have
my @cmds;
my $httpver; # 0 = 1.0, 1 = 1.1, undef = neither
if ($req =~ m!^GET /(\S+) HTTP/(1\.\d+)\r?\n?!) {
@cmds = split(/\s*,\s*/, durl($1));
$httpver = ($2 eq '1.0' ? 0 : ($2 eq '1.1' ? 1 : undef));
}
my $msg = HTTP::Request->parse($req);
# 500 if no commands were given or we don't know their HTTP version
# or we didn't parse a proper HTTP request
unless (@cmds && defined $httpver && $msg) {
print $csock $response->(500);
exit 0;
}
# prepare a simple 200 to send; undef this if you want to control
# your own output below
my $to_send = $response->(200);
foreach my $cmd (@cmds) {
$cmd =~ s/^\s+//;
$cmd =~ s/\s+$//;
if ($cmd =~ /^sleep\s+(\d+)$/i) {
sleep $1+0;
}
if ($cmd =~ /^status$/i) {
$to_send = $response->(200, undef, "pid = $$");
}
}
if (defined $to_send) {
print $csock $to_send;
}
exit 0;
}
exit 0;
}
# de-url escape
sub durl {
my ($a) = @_;
$a =~ tr/+/ /;
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
return $a;
}
1;