/lib/Perlbal/Plugin/Highpri.pm

  1###########################################################################
  2# plugin that makes some requests high priority.  this is very LiveJournal
  3# specific, as this makes requests to the client protocol be treated as
  4# high priority requests.
  5###########################################################################
  6
  7package Perlbal::Plugin::Highpri;
  8
  9use strict;
 10use warnings;
 11
 12# keep track of services we're loaded for
 13our %Services;
 14
 15# called when we're being added to a service
 16sub register {
 17    my ($class, $svc) = @_;
 18
 19    # create a compiled regexp for very frequent use later
 20    my $uri_check = qr{^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$};
 21    my $host_check = undef;
 22
 23    # setup default extra config info
 24    $svc->{extra_config}->{highpri_uri_check_str} = '^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$';
 25    $svc->{extra_config}->{highpri_host_check_str} = 'undef';
 26
 27    # config setter reference
 28    my $config_set = sub {
 29        my ($out, $what, $val) = @_;
 30        return 0 unless $what && $val;
 31
 32        # setup an error sub
 33        my $err = sub {
 34            $out->("ERROR: $_[0]") if $out;
 35            return 0;
 36        };
 37
 38        # if they said undef, that's not a regexp, that means use none
 39        my $temp;
 40        unless ($val eq 'undef' || $val eq 'none' || $val eq 'null') {
 41            # verify this regexp works?  do it in an eval because qr will die
 42            # if we give it something invalid
 43            eval {
 44                $temp = qr{$val};
 45            };
 46            return $err->("Invalid regular expression") if $@ || !$temp;
 47        }
 48
 49        # see what they want to set and set it
 50        if ($what =~ /^uri_pattern/i) {
 51            $uri_check = $temp;
 52            $svc->{extra_config}->{highpri_uri_check_str} = $val;
 53        } elsif ($what =~ /^host_pattern/i) {
 54            $host_check = $temp;
 55            $svc->{extra_config}->{highpri_host_check_str} = $val;
 56        } else {
 57            return $err->("Plugin understands: uri_pattern, host_pattern");
 58        }
 59
 60        # 1 for success!
 61        return 1;
 62    };
 63
 64    # register things to take in configuration regular expressions
 65    $svc->register_setter('Highpri', 'uri_pattern', $config_set);
 66    $svc->register_setter('Highpri', 'host_pattern', $config_set);
 67
 68    # more complicated statistics
 69    $svc->register_hook('Highpri', 'make_high_priority', sub {
 70        my Perlbal::ClientProxy $cp = shift;
 71
 72        # check it against our compiled regexp
 73        return 1 if $uri_check &&
 74                    $cp->{req_headers}->request_uri =~ /$uri_check/;
 75        if ($host_check) {
 76            my $hostname = $cp->{req_headers}->header('Host');
 77            return 1 if $hostname && $hostname =~ /$host_check/;
 78        }
 79
 80        # doesn't fit, so return 0
 81        return 0;
 82    });
 83
 84    # mark this service as being active in this plugin
 85    $Services{"$svc"} = $svc;
 86
 87    return 1;
 88}
 89
 90# called when we're no longer active on a service
 91sub unregister {
 92    my ($class, $svc) = @_;
 93
 94    # clean up time
 95    $svc->unregister_hooks('Highpri');
 96    $svc->unregister_setters('Highpri');
 97    return 1;
 98}
 99
100# load global commands for querying this plugin on what's up
101sub load {
102    # setup a command to see what the patterns are
103    Perlbal::register_global_hook('manage_command.patterns', sub {
104        my @res = ("High priority pattern buffer:");
105
106        foreach my $svc (values %Services) {
107            push @res, "SET $svc->{name}.highpri.uri_pattern = $svc->{extra_config}->{highpri_uri_check_str}";
108            push @res, "SET $svc->{name}.highpri.host_pattern = $svc->{extra_config}->{highpri_host_check_str}";
109        }
110
111        push @res, ".";
112        return \@res;
113    });
114
115    return 1;
116}
117
118# unload our global commands, clear our service object
119sub unload {
120    Perlbal::unregister_global_hook('manage_command.patterns');
121    %Services = ();
122    return 1;
123}
124
1251;