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

init

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

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

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

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

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

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

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

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

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