1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
###########################################################################
# 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 regexp 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}";
}
push @res, ".";
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;
|
