This file is indexed.

/usr/share/perl5/Perlbal/Plugin/Vhosts.pm is in libperlbal-perl 1.80-3.

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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
###########################################################################
# plugin to do name-based virtual hosts
###########################################################################

# things to test:
#   one persistent connection, first to a docs plugin, then to web proxy... see if it returns us to our base class after end of request
#   PUTing a large file to a selector, seeing if it is put correctly to the PUT-enabled web_server proxy
#   obvious cases:  non-existent domains, default domains (*), proper matching (foo.brad.lj before *.brad.lj)
#

package Perlbal::Plugin::Vhosts;

use strict;
use warnings;
no  warnings qw(deprecated);

our %Services;  # service_name => $svc

# when "LOAD" directive loads us up
sub load {
    my $class = shift;

    Perlbal::register_global_hook('manage_command.vhost', sub {
        my $mc = shift->parse(qr/^vhost\s+(?:(\w+)\s+)?(\S+)\s*=\s*(\w+)$/,
                              "usage: VHOST [<service>] <host_or_pattern> = <dest_service>");
        my ($selname, $host, $target) = $mc->args;
        unless ($selname ||= $mc->{ctx}{last_created}) {
            return $mc->err("omitted service name not implied from context");
        }

        my $ss = Perlbal->service($selname);
        return $mc->err("Service '$selname' is not a selector service")
            unless $ss && $ss->{role} eq "selector";

        $host = lc $host;
        return $mc->err("invalid host pattern: '$host'")
            unless $host =~ /^[\w\-\_\.\*\;\:]+$/;

        $ss->{extra_config}->{_vhosts} ||= {};
        $ss->{extra_config}->{_vhosts}{$host} = $target;

        return $mc->ok;
    });
    return 1;
}

# unload our global commands, clear our service object
sub unload {
    my $class = shift;

    Perlbal::unregister_global_hook('manage_command.vhost');
    unregister($class, $_) foreach (values %Services);
    return 1;
}

# called when we're being added to a service
sub register {
    my ($class, $svc) = @_;
    unless ($svc && $svc->{role} eq "selector") {
        die "You can't load the vhost plugin on a service not of role selector.\n";
    }

    $svc->selector(\&vhost_selector);
    $svc->{extra_config}->{_vhosts} = {};

    $Services{"$svc"} = $svc;
    return 1;
}

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;
    $svc->selector(undef);
    delete $Services{"$svc"};
    return 1;
}

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

    my $vhosts = $svc->{extra_config}->{_vhosts};

    return unless $vhosts;

    my @return;

    while (my ($vhost, $target) = each %$vhosts) {
        push @return, "VHOST $vhost = $target";
    }

    return @return;
}

# call back from Service via ClientHTTPBase's event_read calling service->select_new_service(Perlbal::ClientHTTPBase)
sub vhost_selector {
    my Perlbal::ClientHTTPBase $cb = shift;

    my $req = $cb->{req_headers};
    return $cb->_simple_response(404, "Not Found (no reqheaders)") unless $req;

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

    # Browsers and the Apache API considers 'www.example.com.' == 'www.example.com'
    $vhost and $vhost =~ s/\.$//;

    my $uri = $req->request_uri;
    my $maps = $cb->{service}{extra_config}{_vhosts} ||= {};

    # ability to ask for one host, but actually use another.  (for
    # circumventing javascript/java/browser host restrictions when you
    # actually control two domains).
    if ($vhost && $uri =~ m!^/__using/([\w\.]+)(?:/\w+)(?:\?.*)?$!) {
        my $alt_host = $1;

        # update our request object's Host header, if we ended up switching them
        # around with /__using/...
        my $svc_name = $maps->{"$vhost;using:$alt_host"};
        my $svc = $svc_name ? Perlbal->service($svc_name) : undef;
        unless ($svc) {
            $cb->_simple_response(404, "Vhost twiddling not configured for requested pair.");
            return 1;
        }

        $req->header("Host", $alt_host);
        $svc->adopt_base_client($cb);
        return 1;
    }

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

        my $map_name = $maps->{$match_on};
        my $svc = $map_name ? Perlbal->service($map_name) : undef;

        return 0 unless $svc || $force;

        unless ($svc) {
            $cb->_simple_response(404, "Not Found (no configured vhost)");
            return 1;
        }

        $svc->adopt_base_client($cb);
        return 1;
    };

    #  foo.site.com  should match:
    #      foo.site.com
    #    *.foo.site.com  -- this one's questionable, but might as well?
    #        *.site.com
    #        *.com
    #        *

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

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

    # try the literal mapping
    return 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 if $map_using->($wild);

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

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

1;