/lib/Perlbal/Plugin/Redirect.pm

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