865 lines
27 KiB
Perl
Executable File
865 lines
27 KiB
Perl
Executable File
#!/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;
|