libperlbal-perl 1.80-2 / usr / share / perl5 / Perlbal / Plugin / Redirect.pm

This file is indexed.

/usr/share/perl5/Perlbal/Plugin/Redirect.pm is in libperlbal-perl 1.80-2.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  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
126
package Perlbal::Plugin::Redirect;
use strict;
use warnings;

sub handle_request {
    my ($svc, $pb) = @_;

    my $mappings = $svc->{extra_config}{_redirect_host};
    my $req_header = $pb->{req_headers};

    # returns 1 if done with client, 0 if no action taken
    my $map_using = sub {
        my ($match_on) = @_;

        my $target_host = $mappings->{$match_on};

        return 0 unless $target_host;

        my $path = $req_header->request_uri;

        $pb->send_full_response(301, [
            'Location' => "http://$target_host$path",
            'Content-Length' => 0
        ], "");

        return 1;
    };

    # The following is lifted wholesale from the vhosts plugin.
    # FIXME: Factor it out to a utility function, I guess?
    #
    #  foo.site.com  should match:
    #      foo.site.com
    #    *.foo.site.com
    #        *.site.com
    #             *.com
    #                 *

    my $vhost = lc($req_header->header("Host"));

    # if no vhost, just try the * mapping
    return $map_using->("*") unless $vhost;

    # Strip off the :portnumber, if any
    $vhost =~ s/:\d+$//;

    # try the literal mapping
    return 1 if $map_using->($vhost);

    # and now try wildcard mappings, removing one part of the domain
    # at a time until we find something, or end up at "*"

    # first wildcard, prepending the "*."
    my $wild = "*.$vhost";
    return 1 if $map_using->($wild);

    # now peel away subdomains
    while ($wild =~ s/^\*\.[\w\-\_]+/*/) {
        return 1 if $map_using->($wild);
    }

    # last option: use the "*" wildcard
    return $map_using->("*");
}

sub register {
    my ($class, $svc) = @_;

    $svc->register_hook('Redirect', 'start_http_request', sub { handle_request($svc, $_[0]); });
}

sub unregister {
    my ($class, $svc) = @_;
    $svc->unregister_hooks('Redirect');
}

sub handle_redirect_command {
    my $mc = shift->parse(qr/^redirect\s+host\s+(\S+)\s+(\S+)$/, "usage: REDIRECT HOST <match_host> <target_host>");
    my ($match_host, $target_host) = $mc->args;

    my $svcname;
    unless ($svcname ||= $mc->{ctx}{last_created}) {
        return $mc->err("No service name in context from CREATE SERVICE <name> or USE <service_name>");
    }

    my $svc = Perlbal->service($svcname);
    return $mc->err("Non-existent service '$svcname'") unless $svc;

    $svc->{extra_config}{_redirect_host} ||= {};
    $svc->{extra_config}{_redirect_host}{lc($match_host)} = lc($target_host);

    return 1;
}

# called when we are loaded
sub load {
    Perlbal::register_global_hook('manage_command.redirect', \&handle_redirect_command);

    return 1;
}

# called for a global unload
sub unload {
    return 1;
}

1;

=head1 NAME

Perlbal::Plugin::Redirect - Plugin to do redirecting in Perlbal land

=head1 SYNOPSIS

    LOAD redirect
    
    CREATE SERVICE redirector
        SET role = web_server
        SET plugins = redirect
        REDIRECT HOST example.com www.example.net
    ENABLE redirector

=head1 LIMITATIONS

Right now this can only redirect at the hostname level. Also, it just
assumes you want an http: URL.

APT Browse - Built by Thomas Orozco.