init
This commit is contained in:
864
wcmtools/perlbal/lib/Perlbal.pm
Executable file
864
wcmtools/perlbal/lib/Perlbal.pm
Executable file
@@ -0,0 +1,864 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package Perlbal;
|
||||
|
||||
use constant DEBUG => $ENV{PERLBAL_DEBUG} || 0;
|
||||
use constant DEBUG_OBJ => $ENV{PERLBAL_DEBUG_OBJ} || 0;
|
||||
use constant TRACK_STATES => $ENV{PERLBAL_TRACK_STATES} || 0; # if on, track states for "state changes" command
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Socket;
|
||||
use IO::Handle;
|
||||
use IO::File;
|
||||
|
||||
# Try and use IO::AIO or Linux::AIO, if it's around.
|
||||
BEGIN {
|
||||
$Perlbal::OPTMOD_IO_AIO = eval "use IO::AIO (); 1;";
|
||||
$Perlbal::OPTMOD_LINUX_AIO = eval "use Linux::AIO '1.3'; 1;";
|
||||
}
|
||||
|
||||
$Perlbal::AIO_MODE = "none";
|
||||
$Perlbal::AIO_MODE = "ioaio" if $Perlbal::OPTMOD_IO_AIO;
|
||||
$Perlbal::AIO_MODE = "linux" if $Perlbal::OPTMOD_LINUX_AIO;
|
||||
|
||||
use Sys::Syslog;
|
||||
|
||||
use Getopt::Long;
|
||||
use BSD::Resource;
|
||||
use Carp qw(cluck croak);
|
||||
use Errno qw(EBADF);
|
||||
use POSIX ();
|
||||
|
||||
use Perlbal::AIO;
|
||||
use Perlbal::HTTPHeaders;
|
||||
use Perlbal::Service;
|
||||
use Perlbal::Socket;
|
||||
use Perlbal::TCPListener;
|
||||
use Perlbal::StatsListener;
|
||||
use Perlbal::ClientManage;
|
||||
use Perlbal::ClientHTTPBase;
|
||||
use Perlbal::ClientProxy;
|
||||
use Perlbal::ClientHTTP;
|
||||
use Perlbal::BackendHTTP;
|
||||
use Perlbal::ReproxyManager;
|
||||
use Perlbal::Pool;
|
||||
|
||||
END {
|
||||
Linux::AIO::max_parallel(0)
|
||||
if $Perlbal::OPTMOD_LINUX_AIO;
|
||||
IO::AIO::max_parallel(0)
|
||||
if $Perlbal::OPTMOD_IO_AIO;
|
||||
}
|
||||
|
||||
$SIG{'PIPE'} = "IGNORE"; # handled manually
|
||||
|
||||
our(%hooks); # hookname => subref
|
||||
our(%service); # servicename -> Perlbal::Service
|
||||
our(%pool); # poolname => Perlbal::Pool
|
||||
our(%plugins); # plugin => 1 (shows loaded plugins)
|
||||
our($last_error);
|
||||
our $vivify_pools = 1; # if on, allow automatic creation of pools
|
||||
our $foreground = 1; # default to foreground
|
||||
our $track_obj = 0; # default to not track creation locations
|
||||
our $reqs = 0; # total number of requests we've done
|
||||
our $starttime = time(); # time we started
|
||||
our ($lastutime, $laststime, $lastreqs) = (0, 0, 0); # for deltas
|
||||
|
||||
# setup XS status data structures
|
||||
our %XSModules; # ( 'headers' => 'Perlbal::XS::HTTPHeaders' )
|
||||
|
||||
# now include XS files
|
||||
eval "use Perlbal::XS::HTTPHeaders;"; # if we have it, load it
|
||||
|
||||
# setup a USR1 signal handler that tells us to dump some basic statistics
|
||||
# of how we're doing to the syslog
|
||||
$SIG{'USR1'} = sub {
|
||||
my $dumper = sub { Perlbal::log('info', $_[0]); };
|
||||
foreach my $svc (values %service) {
|
||||
run_manage_command("show service $svc->{name}", $dumper);
|
||||
}
|
||||
run_manage_command('states', $dumper);
|
||||
run_manage_command('queues', $dumper);
|
||||
};
|
||||
|
||||
sub error {
|
||||
$last_error = shift;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# Object instance counts, for debugging and leak detection
|
||||
our(%ObjCount); # classname -> instances
|
||||
our(%ObjTotal); # classname -> instances
|
||||
our(%ObjTrack); # "$objref" -> creation location
|
||||
sub objctor {
|
||||
if (DEBUG_OBJ) {
|
||||
my $ref = ref $_[0];
|
||||
$ref .= "-$_[1]" if $_[1];
|
||||
$ObjCount{$ref}++;
|
||||
$ObjTotal{$ref}++;
|
||||
|
||||
# now, if we're tracing leaks, note this object's creation location
|
||||
if ($track_obj) {
|
||||
my $i = 1;
|
||||
my @list;
|
||||
while (my $sub = (caller($i++))[3]) {
|
||||
push @list, $sub;
|
||||
}
|
||||
$ObjTrack{"$_[0]"} = [ time, join(', ', @list) ];
|
||||
}
|
||||
}
|
||||
}
|
||||
sub objdtor {
|
||||
if (DEBUG_OBJ) {
|
||||
my $ref = ref $_[0];
|
||||
$ref .= "-$_[1]" if $_[1];
|
||||
$ObjCount{$ref}--;
|
||||
|
||||
# remove tracking for this object
|
||||
if ($track_obj) {
|
||||
delete $ObjTrack{"$_[0]"};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub register_global_hook {
|
||||
$hooks{$_[0]} = $_[1];
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub unregister_global_hook {
|
||||
delete $hooks{$_[0]};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub run_global_hook {
|
||||
my $ref = $hooks{$_[0]};
|
||||
return $ref->(@_) if defined $ref;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub service_names {
|
||||
return sort keys %service;
|
||||
}
|
||||
|
||||
sub service {
|
||||
my $class = shift;
|
||||
return $service{$_[0]};
|
||||
}
|
||||
|
||||
sub pool {
|
||||
my $class = shift;
|
||||
return $pool{$_[0]};
|
||||
}
|
||||
|
||||
# returns 1 if command succeeded, 0 otherwise
|
||||
sub run_manage_command {
|
||||
my ($cmd, $out, $verbose) = @_; # $out is output stream closure
|
||||
$cmd =~ s/\#.*//;
|
||||
$cmd =~ s/^\s+//;
|
||||
$cmd =~ s/\s+$//;
|
||||
$cmd =~ s/\s+/ /g;
|
||||
my $orig = $cmd; # save original case for some commands
|
||||
$cmd =~ s/^([^=]+)/lc $1/e; # lowercase everything up to an =
|
||||
return 1 unless $cmd =~ /\S/;
|
||||
|
||||
$out ||= sub {};
|
||||
|
||||
my $err = sub {
|
||||
$out->("ERROR: $_[0]");
|
||||
return 0;
|
||||
};
|
||||
my $ok = sub {
|
||||
$out->("OK") if $verbose;
|
||||
return 1;
|
||||
};
|
||||
|
||||
if ($cmd =~ /^obj$/) {
|
||||
foreach (sort keys %ObjCount) {
|
||||
$out->("$_ = $ObjCount{$_} (tot=$ObjTotal{$_})");
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd eq "shutdown") {
|
||||
Linux::AIO::max_parallel(0) if $Perlbal::OPTMOD_LINUX_AIO;
|
||||
IO::AIO::max_parallel(0) if $Perlbal::OPTMOD_IO_AIO;
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($cmd =~ /^xs(?:\s+(\w+)\s+(\w+))?$/) {
|
||||
if ($1 && $2) {
|
||||
# command? verify
|
||||
my ($cmd, $module) = ($1, $2);
|
||||
return $err->('Known XS modules: ' . join(', ', sort keys %XSModules) . '.')
|
||||
unless $XSModules{$module};
|
||||
|
||||
# okay, so now enable or disable this module
|
||||
if ($cmd eq 'enable') {
|
||||
my $res = eval "return $XSModules{$module}::enable();";
|
||||
return $err->("Unable to enable module.")
|
||||
unless $res;
|
||||
$out->("Module enabled.");
|
||||
} elsif ($cmd eq 'disable') {
|
||||
my $res = eval "return $XSModules{$module}::disable();";
|
||||
return $err->("Unable to disable module.")
|
||||
unless $res;
|
||||
$out->("Module disabled.");
|
||||
} else {
|
||||
return $err->('Usage: xs [ <enable|disable> <module> ]');
|
||||
}
|
||||
} else {
|
||||
# no commands, so just check status
|
||||
$out->('XS module status:', '');
|
||||
foreach my $module (sort keys %XSModules) {
|
||||
my $class = $XSModules{$module};
|
||||
my $enabled = eval "return \$${class}::Enabled;";
|
||||
my $status = defined $enabled ? ($enabled ? "installed, enabled" :
|
||||
"installed, disabled") : "not installed";
|
||||
$out->(" $module: $status");
|
||||
}
|
||||
$out->(' No modules available.') unless %XSModules;
|
||||
$out->('');
|
||||
$out->("To enable a module: xs enable <module>");
|
||||
$out->("To disable a module: xs disable <module>");
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^fd/) {
|
||||
# called in list context on purpose, but we want the hard limit
|
||||
my (undef, $max) = getrlimit(RLIMIT_NOFILE);
|
||||
my $ct = 0;
|
||||
|
||||
# first try procfs if one exists, as that's faster than iterating
|
||||
if (opendir(DIR, "/proc/self/fd")) {
|
||||
my @dirs = readdir(DIR);
|
||||
$ct = scalar(@dirs) - 2; # don't count . and ..
|
||||
closedir(DIR);
|
||||
} else {
|
||||
# isatty() is cheap enough to do on everything
|
||||
foreach (0..$max) {
|
||||
my $res = POSIX::isatty($_);
|
||||
$ct++ if $res || ($! != EBADF);
|
||||
}
|
||||
}
|
||||
$out->("max $max");
|
||||
$out->("cur $ct");
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^proc/) {
|
||||
my $ru = getrusage();
|
||||
my ($ut, $st) = ($ru->utime, $ru->stime);
|
||||
my ($udelta, $sdelta) = ($ut - $lastutime, $st - $laststime);
|
||||
my $rdelta = $reqs - $lastreqs;
|
||||
$out->('time: ' . time());
|
||||
$out->('pid: ' . $$);
|
||||
$out->("utime: $ut (+$udelta)");
|
||||
$out->("stime: $st (+$sdelta)");
|
||||
$out->("reqs: $reqs (+$rdelta)");
|
||||
($lastutime, $laststime, $lastreqs) = ($ut, $st, $reqs);
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^nodes?(?:\s+(\d+.\d+.\d+.\d+)(?::(\d+))?)?$/) {
|
||||
my ($ip, $port) = ($1, $2 || 80);
|
||||
my $spec_ipport = $ip ? "$ip:$port" : undef;
|
||||
my $ref = \%Perlbal::BackendHTTP::NodeStats;
|
||||
|
||||
my $dump = sub {
|
||||
my $ipport = shift;
|
||||
foreach my $key (keys %{$ref->{$ipport}}) {
|
||||
if (ref $ref->{$ipport}->{$key} eq 'ARRAY') {
|
||||
my %temp;
|
||||
$temp{$_}++ foreach @{$ref->{$ipport}->{$key}};
|
||||
foreach my $tkey (keys %temp) {
|
||||
$out->("$ipport $key $tkey $temp{$tkey}");
|
||||
}
|
||||
} else {
|
||||
$out->("$ipport $key $ref->{$ipport}->{$key}");
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
# dump a node, or all nodes
|
||||
if ($spec_ipport) {
|
||||
$dump->($spec_ipport);
|
||||
} else {
|
||||
foreach my $ipport (keys %$ref) {
|
||||
$dump->($ipport);
|
||||
}
|
||||
}
|
||||
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^prof\w*\s+(on|off|data)/) {
|
||||
my $which = $1;
|
||||
if ($which eq 'on') {
|
||||
if (Danga::Socket->EnableProfiling) {
|
||||
$out->('Profiling enabled.');
|
||||
} else {
|
||||
$out->('Unable to enable profiling. Please ensure you have the BSD::Resource module installed.');
|
||||
}
|
||||
} elsif ($which eq 'off') {
|
||||
Danga::Socket->DisableProfiling;
|
||||
$out->('Profiling disabled.');
|
||||
} elsif ($which eq 'data') {
|
||||
my $href = Danga::Socket->ProfilingData;
|
||||
foreach my $key (sort keys %$href) {
|
||||
my ($utime, $stime, $calls) = @{$href->{$key}};
|
||||
$out->(sprintf("%s %0.5f %0.5f %d %0.7f %0.7f",
|
||||
$key, $utime, $stime, $calls, $utime / $calls, $stime / $calls));
|
||||
}
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^uptime/) {
|
||||
$out->("starttime $starttime");
|
||||
$out->("uptime " . (time() - $starttime));
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^track/) {
|
||||
my $now = time();
|
||||
my @list;
|
||||
foreach (keys %ObjTrack) {
|
||||
my $age = $now - $ObjTrack{$_}->[0];
|
||||
push @list, [ $age, "${age}s $_: $ObjTrack{$_}->[1]" ];
|
||||
}
|
||||
|
||||
# now output based on sorted age
|
||||
foreach (sort { $a->[0] <=> $b->[0] } @list) {
|
||||
$out->($_->[1]);
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd eq 'shutdown graceful') {
|
||||
# set connect ahead to 0 for all services so they don't spawn extra backends
|
||||
foreach my $svc (values %service) {
|
||||
$svc->{connect_ahead} = 0;
|
||||
}
|
||||
|
||||
# tell all sockets we're doing a graceful stop
|
||||
my $sf = Perlbal::Socket->get_sock_ref;
|
||||
foreach my $k (keys %$sf) {
|
||||
my Perlbal::Socket $v = $sf->{$k};
|
||||
$v->die_gracefully();
|
||||
}
|
||||
|
||||
# register a post loop callback that will end the event loop when we only have
|
||||
# a single socket left, the AIO socket
|
||||
Perlbal::Socket->SetPostLoopCallback(sub {
|
||||
my ($descmap, $otherfds) = @_;
|
||||
|
||||
# Ghetto: duplicate the code we already had for our postloopcallback
|
||||
Perlbal::Socket::run_callbacks();
|
||||
|
||||
# see what we have here; make sure we have no Clients and no unbored Backends
|
||||
foreach my $sock (values %$descmap) {
|
||||
my $ref = ref $sock;
|
||||
return 1 if $ref =~ /^Perlbal::Client/ && $ref ne 'Perlbal::ClientManage';
|
||||
return 1 if $sock->isa('Perlbal::BackendHTTP') && $sock->{state} ne 'bored';
|
||||
}
|
||||
return 0; # end the event loop and thus we exit perlbal
|
||||
});
|
||||
|
||||
# so they know something happened
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^socks(?: (\w+))?$/) {
|
||||
my $mode = $1 || "all";
|
||||
my $sf = Perlbal::Socket->get_sock_ref;
|
||||
|
||||
if ($mode eq "summary") {
|
||||
my %count;
|
||||
my $write_buf = 0;
|
||||
my $open_files = 0;
|
||||
while (my $k = each %$sf) {
|
||||
my Perlbal::Socket $v = $sf->{$k};
|
||||
$count{ref $v}++;
|
||||
$write_buf += $v->{write_buf_size};
|
||||
if ($v->isa("Perlbal::ClientHTTPBase")) {
|
||||
my Perlbal::ClientHTTPBase $cv = $v;
|
||||
$open_files++ if $cv->{'reproxy_fh'};
|
||||
}
|
||||
}
|
||||
|
||||
foreach (sort keys %count) {
|
||||
$out->(sprintf("%5d $_", $count{$_}));
|
||||
}
|
||||
$out->();
|
||||
$out->(sprintf("Aggregate write buffer: %.1fk", $write_buf / 1024));
|
||||
$out->(sprintf(" Open files: %d", $open_files));
|
||||
|
||||
} elsif ($mode eq "all") {
|
||||
|
||||
my $now = time;
|
||||
$out->(sprintf("%5s %6s", "fd", "age"));
|
||||
foreach (sort { $a <=> $b } keys %$sf) {
|
||||
my $sock = $sf->{$_};
|
||||
my $age = $now - $sock->{create_time};
|
||||
$out->(sprintf("%5d %5ds %s", $_, $age, $sock->as_string));
|
||||
}
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^backends$/) {
|
||||
my $sf = Perlbal::Socket->get_sock_ref;
|
||||
|
||||
my %nodes; # { "Backend" => int count }
|
||||
foreach my $sock (values %$sf) {
|
||||
if ($sock->isa("Perlbal::BackendHTTP")) {
|
||||
my Perlbal::BackendHTTP $cv = $sock;
|
||||
$nodes{"$cv->{ipport}"}++;
|
||||
}
|
||||
}
|
||||
|
||||
# now print out text
|
||||
foreach my $node (sort keys %nodes) {
|
||||
$out->("$node " . $nodes{$node});
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^noverify$/) {
|
||||
# shows the amount of time left for each node marked as noverify
|
||||
my $now = time;
|
||||
foreach my $ipport (keys %Perlbal::BackendHTTP::NoVerify) {
|
||||
my $until = $Perlbal::BackendHTTP::NoVerify{$ipport} - $now;
|
||||
$out->("$ipport $until");
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^pending$/) {
|
||||
# shows pending backend connections by service, node, and age
|
||||
my %pend; # { "service" => { "ip:port" => age } }
|
||||
my $now = time;
|
||||
|
||||
foreach my $svc (values %service) {
|
||||
foreach my $ipport (keys %{$svc->{pending_connects}}) {
|
||||
my Perlbal::BackendHTTP $be = $svc->{pending_connects}->{$ipport};
|
||||
next unless defined $be;
|
||||
$pend{$svc->{name}}->{$ipport} = $now - $be->{create_time};
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $name (sort keys %pend) {
|
||||
foreach my $ipport (sort keys %{$pend{$name}}) {
|
||||
$out->("$name $ipport $pend{$name}{$ipport}");
|
||||
}
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^states(?:\s+(.+))?$/) {
|
||||
my $sf = Perlbal::Socket->get_sock_ref;
|
||||
|
||||
my $svc;
|
||||
if (defined $1) {
|
||||
$svc = $service{$1};
|
||||
return $err->("Service not found.")
|
||||
unless defined $svc;
|
||||
}
|
||||
|
||||
my %states; # { "Class" => { "State" => int count; } }
|
||||
foreach my $sock (values %$sf) {
|
||||
my $state = $sock->state;
|
||||
next unless defined $state;
|
||||
if (defined $svc) {
|
||||
next unless $sock->isa('Perlbal::ClientProxy') ||
|
||||
$sock->isa('Perlbal::BackendHTTP') ||
|
||||
$sock->isa('Perlbal::ClientHTTP');
|
||||
next unless $sock->{service} == $svc;
|
||||
}
|
||||
$states{ref $sock}->{$state}++;
|
||||
}
|
||||
|
||||
# now print out text
|
||||
foreach my $class (sort keys %states) {
|
||||
foreach my $state (sort keys %{$states{$class}}) {
|
||||
$out->("$class $state " . $states{$class}->{$state});
|
||||
}
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^queues$/) {
|
||||
my $now = time;
|
||||
|
||||
foreach my $svc (values %service) {
|
||||
next unless $svc->{role} eq 'reverse_proxy';
|
||||
|
||||
my ($age, $count) = (0, scalar(@{$svc->{waiting_clients}}));
|
||||
my Perlbal::ClientProxy $oldest = $svc->{waiting_clients}->[0];
|
||||
$age = $now - $oldest->{last_request_time} if defined $oldest;
|
||||
$out->("$svc->{name}-normal.age $age");
|
||||
$out->("$svc->{name}-normal.count $count");
|
||||
|
||||
($age, $count) = (0, scalar(@{$svc->{waiting_clients_highpri}}));
|
||||
$oldest = $svc->{waiting_clients_highpri}->[0];
|
||||
$age = $now - $oldest->{last_request_time} if defined $oldest;
|
||||
$out->("$svc->{name}-highpri.age $age");
|
||||
$out->("$svc->{name}-highpri.count $count");
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^state changes$/) {
|
||||
my $hr = Perlbal::Socket->get_statechange_ref;
|
||||
my %final; # { "state" => count }
|
||||
while (my ($obj, $arref) = each %$hr) {
|
||||
$out->("$obj: " . join(', ', @$arref));
|
||||
$final{$arref->[-1]}++;
|
||||
}
|
||||
foreach my $k (sort keys %final) {
|
||||
$out->("$k $final{$k}");
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
# iterates over active objects. if you specify an argument, it is treated as code
|
||||
# with $_ being the reference to the object.
|
||||
if ($cmd =~ /^leaks(?:\s+(.+))?$/) {
|
||||
# shows objects that we think might have been leaked
|
||||
my $ref = Perlbal::Socket::get_created_objects_ref;
|
||||
foreach (@$ref) {
|
||||
next unless $_; # might be undef!
|
||||
if ($1) {
|
||||
my $rv = eval "$1";
|
||||
return $err->("$@") if $@;
|
||||
next unless defined $rv;
|
||||
$out->($rv);
|
||||
} else {
|
||||
$out->($_->as_string);
|
||||
}
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^show service (\w+)$/) {
|
||||
my $sname = $1;
|
||||
my Perlbal::Service $svc = $service{$sname};
|
||||
return $err->("Unknown service") unless $svc;
|
||||
$svc->stats_info($out);
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^server (\S+) ?= ?(.+)$/) {
|
||||
my ($key, $val) = ($1, $2);
|
||||
|
||||
if ($key =~ /^max_reproxy_connections(?:\((.+)\))?/) {
|
||||
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
|
||||
my $hostip = $1;
|
||||
if (defined $hostip) {
|
||||
$Perlbal::ReproxyManager::ReproxyMax{$hostip} = $val+0;
|
||||
} else {
|
||||
$Perlbal::ReproxyManager::ReproxyGlobalMax = $val+0;
|
||||
}
|
||||
|
||||
} elsif ($key eq "max_connections") {
|
||||
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
|
||||
my $rv = setrlimit(RLIMIT_NOFILE, $val, $val);
|
||||
unless (defined $rv && $rv) {
|
||||
if ($> == 0) {
|
||||
$err->("Unable to set limit.");
|
||||
} else {
|
||||
$err->("Need to be root to increase max connections.");
|
||||
}
|
||||
}
|
||||
} elsif ($key eq "nice_level") {
|
||||
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
|
||||
my $rv = POSIX::nice($val);
|
||||
$err->("Unable to renice: $!")
|
||||
unless defined $rv;
|
||||
|
||||
} elsif ($key eq "aio_threads") {
|
||||
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
|
||||
Linux::AIO::min_parallel($val)
|
||||
if $Perlbal::OPTMOD_LINUX_AIO;
|
||||
IO::AIO::min_parallel($val)
|
||||
if $Perlbal::OPTMOD_IO_AIO;
|
||||
|
||||
} elsif ($key =~ /^track_obj/) {
|
||||
return $err->("Expected 1 or 0") unless $val eq '1' || $val eq '0';
|
||||
$track_obj = $val + 0;
|
||||
%ObjTrack = () if $val; # if we're turning it on, clear it out
|
||||
|
||||
} elsif ($key eq "aio_mode") {
|
||||
return $err->("Unknown AIO mode") unless $val =~ /^none|linux|ioaio$/;
|
||||
return $err->("Linux::AIO not available") if $val eq "linux" && ! $Perlbal::OPTMOD_LINUX_AIO;
|
||||
return $err->("IO::AIO not available") if $val eq "ioaio" && ! $Perlbal::OPTMOD_IO_AIO;
|
||||
$Perlbal::AIO_MODE = $val;
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
if ($cmd =~ /^reproxy_state/) {
|
||||
Perlbal::ReproxyManager::dump_state($out);
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
if ($cmd =~ /^create service (\w+)$/) {
|
||||
my $name = $1;
|
||||
return $err->("service '$name' already exists") if $service{$name};
|
||||
return $err->("pool '$name' already exists") if $pool{$name};
|
||||
$service{$name} = Perlbal::Service->new($name);
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
if ($cmd =~ /^create pool (\w+)$/) {
|
||||
my $name = $1;
|
||||
return $err->("pool '$name' already exists") if $pool{$name};
|
||||
return $err->("service '$name' already exists") if $service{$name};
|
||||
$vivify_pools = 0;
|
||||
$pool{$name} = Perlbal::Pool->new($name);
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
# pool add <pool> <ipport>
|
||||
# pool <pool> add <ipport>
|
||||
# ... or 'remove' instead of 'add'
|
||||
if ($cmd =~ /^pool (\w+) (\w+) (\d+.\d+.\d+.\d+)(?::(\d+))?$/) {
|
||||
my ($cmd, $name, $ip, $port) = ($1, $2, $3, $4 || 80);
|
||||
if ($name =~ /^(?:add|remove)$/) {
|
||||
($cmd, $name) = ($name, $cmd);
|
||||
}
|
||||
my $pl = $pool{$name};
|
||||
return $err->("Pool '$name' not found") unless $pl;
|
||||
$pl->$cmd($ip, $port);
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
if ($cmd =~ /^show pool(?:\s+(\w+))?$/) {
|
||||
my $pool = $1;
|
||||
if ($pool) {
|
||||
my $pl = $pool{$pool};
|
||||
return $err->("pool '$pool' does not exist") unless $pl;
|
||||
|
||||
foreach my $node (@{ $pl->nodes }) {
|
||||
my $ipport = "$node->[0]:$node->[1]";
|
||||
$out->($ipport . " " . $pl->node_used($ipport));
|
||||
}
|
||||
} else {
|
||||
foreach my $name (sort keys %pool) {
|
||||
my Perlbal::Pool $pl = $pool{$name};
|
||||
$out->("$name nodes $pl->{node_count}");
|
||||
$out->("$name services $pl->{use_count}");
|
||||
}
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^show service$/) {
|
||||
foreach my $name (sort keys %service) {
|
||||
my $svc = $service{$name};
|
||||
$out->("$name $svc->{listen} " . ($svc->{enabled} ? "ENABLED" : "DISABLED"));
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^set (\w+)\.([\w\.]+) ?= ?(.+)$/) {
|
||||
my ($name, $key, $val) = ($1, $2, $3);
|
||||
if (my Perlbal::Service $svc = $service{$name}) {
|
||||
return $svc->set($key, $val, $out, $verbose);
|
||||
} elsif (my Perlbal::Pool $pl = $pool{$name}) {
|
||||
return $pl->set($key, $val, $out, $verbose);
|
||||
}
|
||||
return $err->("service/pool '$name' does not exist");
|
||||
}
|
||||
|
||||
if ($orig =~ /^header\s+(\w+)\s+(\w+)\s+(.+?)(?:\s*:\s*(.+))?$/i) {
|
||||
my ($mode, $name, $header, $val) = (lc $1, lc $2, $3, $4);
|
||||
return $err->("format: header <insert|remove> <service> <header>[: <value>]")
|
||||
unless $mode =~ /^(?:insert|remove)$/;
|
||||
my $svc = $service{$name};
|
||||
return $err->("service '$name' does not exist") unless $svc;
|
||||
return $ok->()
|
||||
if $svc->header_management($mode, $header, $val, $out);
|
||||
}
|
||||
|
||||
if ($cmd =~ /^(disable|enable) (\w+)$/) {
|
||||
my ($verb, $name) = ($1, $2);
|
||||
my $svc = $service{$name};
|
||||
return $err->("service '$name' does not exist") unless $svc;
|
||||
return $ok->()
|
||||
if $svc->$verb($out);
|
||||
}
|
||||
|
||||
if ($cmd =~ /^(un)?load (\w+)$/) {
|
||||
my $un = $1 ? $1 : '';
|
||||
my $fn = $2;
|
||||
if (length $fn) {
|
||||
# since we lowercase our input, uppercase the first character here
|
||||
$fn = uc($1) . lc($2) if $fn =~ /^(.)(.*)$/;
|
||||
eval "use Perlbal::Plugin::$fn; Perlbal::Plugin::$fn->${un}load;";
|
||||
return $err->($@) if $@;
|
||||
$plugins{$fn} = $un ? 0 : 1;
|
||||
}
|
||||
return $ok->();
|
||||
}
|
||||
|
||||
if ($cmd =~ /^plugins$/) {
|
||||
foreach my $svc (values %service) {
|
||||
next unless @{$svc->{plugin_order}};
|
||||
$out->(join(' ', $svc->{name}, @{$svc->{plugin_order}}));
|
||||
}
|
||||
$out->('.');
|
||||
return 1;
|
||||
}
|
||||
|
||||
# call any hooks if they've been defined
|
||||
my $lcmd = $cmd =~ /^(.+?)\s+/ ? $1 : $cmd;
|
||||
my $rval = run_global_hook("manage_command.$lcmd", $cmd);
|
||||
return $out->($rval, '.') if defined $rval;
|
||||
|
||||
return $err->("unknown command: $cmd");
|
||||
}
|
||||
|
||||
sub load_config {
|
||||
my ($file, $writer) = @_;
|
||||
open (F, $file) or die "Error opening config file ($file): $!\n";
|
||||
my $verbose = 0;
|
||||
while (<F>) {
|
||||
if ($_ =~ /^verbose (on|off)/i) {
|
||||
$verbose = (lc $1 eq 'on' ? 1 : 0);
|
||||
next;
|
||||
}
|
||||
return 0 unless run_manage_command($_, $writer, $verbose);
|
||||
}
|
||||
close(F);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub daemonize {
|
||||
my($pid, $sess_id, $i);
|
||||
|
||||
# note that we're not in the foreground (for logging purposes)
|
||||
$foreground = 0;
|
||||
|
||||
# required before fork: (as of Linux::AIO 1.1, but may change)
|
||||
Linux::AIO::max_parallel(0)
|
||||
if $Perlbal::OPTMOD_LINUX_AIO;
|
||||
IO::AIO::max_parallel(0)
|
||||
if $Perlbal::OPTMOD_IO_AIO;
|
||||
|
||||
## Fork and exit parent
|
||||
if ($pid = fork) { exit 0; }
|
||||
|
||||
## Detach ourselves from the terminal
|
||||
croak "Cannot detach from controlling terminal"
|
||||
unless $sess_id = POSIX::setsid();
|
||||
|
||||
## Prevent possibility of acquiring a controling terminal
|
||||
$SIG{'HUP'} = 'IGNORE';
|
||||
if ($pid = fork) { exit 0; }
|
||||
|
||||
## Change working directory
|
||||
chdir "/";
|
||||
|
||||
## Clear file creation mask
|
||||
umask 0;
|
||||
|
||||
## Close open file descriptors
|
||||
close(STDIN);
|
||||
close(STDOUT);
|
||||
close(STDERR);
|
||||
|
||||
## Reopen stderr, stdout, stdin to /dev/null
|
||||
open(STDIN, "+>/dev/null");
|
||||
open(STDOUT, "+>&STDIN");
|
||||
open(STDERR, "+>&STDIN");
|
||||
}
|
||||
|
||||
sub run {
|
||||
# setup for logging
|
||||
openlog('perlbal', 'pid', 'daemon');
|
||||
Perlbal::log('info', 'beginning run');
|
||||
|
||||
# number of AIO threads. the number of outstanding requests isn't
|
||||
# affected by this
|
||||
Linux::AIO::min_parallel(3) if $Perlbal::OPTMOD_LINUX_AIO;
|
||||
IO::AIO::min_parallel(3) if $Perlbal::OPTMOD_IO_AIO;
|
||||
|
||||
# register Linux::AIO's pipe which gets written to from threads
|
||||
# doing blocking IO
|
||||
if ($Perlbal::OPTMOD_LINUX_AIO) {
|
||||
Perlbal::Socket->AddOtherFds(Linux::AIO::poll_fileno() =>
|
||||
\&Linux::AIO::poll_cb)
|
||||
}
|
||||
if ($Perlbal::OPTMOD_IO_AIO) {
|
||||
Perlbal::Socket->AddOtherFds(IO::AIO::poll_fileno() =>
|
||||
\&IO::AIO::poll_cb);
|
||||
}
|
||||
|
||||
|
||||
Danga::Socket->SetLoopTimeout(1000);
|
||||
Danga::Socket->SetPostLoopCallback(sub {
|
||||
Perlbal::Socket::run_callbacks();
|
||||
return 1;
|
||||
});
|
||||
|
||||
# begin the overall loop to try to capture if Perlbal dies at some point
|
||||
# so we can have a log of it
|
||||
eval {
|
||||
# wait for activity
|
||||
Perlbal::Socket->EventLoop();
|
||||
};
|
||||
|
||||
# closing messages
|
||||
if ($@) {
|
||||
Perlbal::log('crit', "crash log: $_") foreach split(/\r?\n/, $@);
|
||||
}
|
||||
Perlbal::log('info', 'ending run');
|
||||
closelog();
|
||||
}
|
||||
|
||||
sub log {
|
||||
# simple logging functionality
|
||||
if ($foreground) {
|
||||
# syslog acts like printf so we have to use printf and append a \n
|
||||
shift; # ignore the first parameter (info, warn, critical, etc)
|
||||
printf(shift(@_) . "\n", @_);
|
||||
} else {
|
||||
# just pass the parameters to syslog
|
||||
syslog(@_);
|
||||
}
|
||||
}
|
||||
|
||||
# Local Variables:
|
||||
# mode: perl
|
||||
# c-basic-indent: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
|
||||
1;
|
||||
101
wcmtools/perlbal/lib/Perlbal/AIO.pm
Executable file
101
wcmtools/perlbal/lib/Perlbal/AIO.pm
Executable 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
570
wcmtools/perlbal/lib/Perlbal/BackendHTTP.pm
Executable 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
339
wcmtools/perlbal/lib/Perlbal/ClientHTTP.pm
Executable 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
480
wcmtools/perlbal/lib/Perlbal/ClientHTTPBase.pm
Executable 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
139
wcmtools/perlbal/lib/Perlbal/ClientManage.pm
Executable 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
507
wcmtools/perlbal/lib/Perlbal/ClientProxy.pm
Executable 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
411
wcmtools/perlbal/lib/Perlbal/HTTPHeaders.pm
Executable 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
124
wcmtools/perlbal/lib/Perlbal/Plugin/Highpri.pm
Executable 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
293
wcmtools/perlbal/lib/Perlbal/Plugin/Palimg.pm
Executable 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
54
wcmtools/perlbal/lib/Perlbal/Plugin/Queues.pm
Executable 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
161
wcmtools/perlbal/lib/Perlbal/Plugin/Stats.pm
Executable 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
328
wcmtools/perlbal/lib/Perlbal/Pool.pm
Executable 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
248
wcmtools/perlbal/lib/Perlbal/ReproxyManager.pm
Executable 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
907
wcmtools/perlbal/lib/Perlbal/Service.pm
Executable 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
279
wcmtools/perlbal/lib/Perlbal/Socket.pm
Executable 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
219
wcmtools/perlbal/lib/Perlbal/StatsListener.pm
Executable 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
95
wcmtools/perlbal/lib/Perlbal/TCPListener.pm
Executable 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
134
wcmtools/perlbal/lib/Perlbal/Test.pm
Executable 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
127
wcmtools/perlbal/lib/Perlbal/Test/WebClient.pm
Executable 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
114
wcmtools/perlbal/lib/Perlbal/Test/WebServer.pm
Executable 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;
|
||||
Reference in New Issue
Block a user