/lib/Perlbal/Plugin/Highpri.pm

http://github.com/perlbal/Perlbal · Perl · 125 lines · 74 code · 25 blank · 26 comment · 12 complexity · d7884a9dd36a2e4d3ca8ef3653423d5e MD5 · raw file

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