/lib/Perlbal/Plugin/Redirect.pm

http://github.com/perlbal/Perlbal · Perl · 126 lines · 70 code · 36 blank · 20 comment · 4 complexity · 644b0dbea36f1ac9cb6370b5bb593112 MD5 · raw file

  1. package Perlbal::Plugin::Redirect;
  2. use strict;
  3. use warnings;
  4. sub handle_request {
  5. my ($svc, $pb) = @_;
  6. my $mappings = $svc->{extra_config}{_redirect_host};
  7. my $req_header = $pb->{req_headers};
  8. # returns 1 if done with client, 0 if no action taken
  9. my $map_using = sub {
  10. my ($match_on) = @_;
  11. my $target_host = $mappings->{$match_on};
  12. return 0 unless $target_host;
  13. my $path = $req_header->request_uri;
  14. $pb->send_full_response(301, [
  15. 'Location' => "http://$target_host$path",
  16. 'Content-Length' => 0
  17. ], "");
  18. return 1;
  19. };
  20. # The following is lifted wholesale from the vhosts plugin.
  21. # FIXME: Factor it out to a utility function, I guess?
  22. #
  23. # foo.site.com should match:
  24. # foo.site.com
  25. # *.foo.site.com
  26. # *.site.com
  27. # *.com
  28. # *
  29. my $vhost = lc($req_header->header("Host"));
  30. # if no vhost, just try the * mapping
  31. return $map_using->("*") unless $vhost;
  32. # Strip off the :portnumber, if any
  33. $vhost =~ s/:\d+$//;
  34. # try the literal mapping
  35. return 1 if $map_using->($vhost);
  36. # and now try wildcard mappings, removing one part of the domain
  37. # at a time until we find something, or end up at "*"
  38. # first wildcard, prepending the "*."
  39. my $wild = "*.$vhost";
  40. return 1 if $map_using->($wild);
  41. # now peel away subdomains
  42. while ($wild =~ s/^\*\.[\w\-\_]+/*/) {
  43. return 1 if $map_using->($wild);
  44. }
  45. # last option: use the "*" wildcard
  46. return $map_using->("*");
  47. }
  48. sub register {
  49. my ($class, $svc) = @_;
  50. $svc->register_hook('Redirect', 'start_http_request', sub { handle_request($svc, $_[0]); });
  51. }
  52. sub unregister {
  53. my ($class, $svc) = @_;
  54. $svc->unregister_hooks('Redirect');
  55. }
  56. sub handle_redirect_command {
  57. my $mc = shift->parse(qr/^redirect\s+host\s+(\S+)\s+(\S+)$/, "usage: REDIRECT HOST <match_host> <target_host>");
  58. my ($match_host, $target_host) = $mc->args;
  59. my $svcname;
  60. unless ($svcname ||= $mc->{ctx}{last_created}) {
  61. return $mc->err("No service name in context from CREATE SERVICE <name> or USE <service_name>");
  62. }
  63. my $svc = Perlbal->service($svcname);
  64. return $mc->err("Non-existent service '$svcname'") unless $svc;
  65. $svc->{extra_config}{_redirect_host} ||= {};
  66. $svc->{extra_config}{_redirect_host}{lc($match_host)} = lc($target_host);
  67. return 1;
  68. }
  69. # called when we are loaded
  70. sub load {
  71. Perlbal::register_global_hook('manage_command.redirect', \&handle_redirect_command);
  72. return 1;
  73. }
  74. # called for a global unload
  75. sub unload {
  76. return 1;
  77. }
  78. 1;
  79. =head1 NAME
  80. Perlbal::Plugin::Redirect - Plugin to do redirecting in Perlbal land
  81. =head1 SYNOPSIS
  82. LOAD redirect
  83. CREATE SERVICE redirector
  84. SET role = web_server
  85. SET plugins = redirect
  86. REDIRECT HOST example.com www.example.net
  87. ENABLE redirector
  88. =head1 LIMITATIONS
  89. Right now this can only redirect at the hostname level. Also, it just
  90. assumes you want an http: URL.