root/trunk/lib/Perlbal/Plugin/AccessControl.pm

package Perlbal::Plugin::AccessControl;

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

# commands like:
#
# what to do if we fall off the rule chain:
#     ACCESS POLICY {ALLOW,DENY}
#
# adding things to the rule chain.  processing stops once any rule is matched.
#
#     ACCESS {ALLOW,DENY} netmask 127.0.0.1/8
#     ACCESS {ALLOW,DENY} ip 127.0.0.1
# also can make a match set the request to go into the low-priority perlbal queue:
#     ACCESS QUEUE_LOW ip 127.0.0.1

# reset the rule chain and policy:  (policy is allow by default)
#     ACCESS RESET

# Future:
#  access {allow,deny} forwarded_ip 127.0.0.1
#  access {allow,deny} method <method>[,<method>]*
#  access {allow,deny} forwarded_netmask 127.0.0.1/24

sub load {
    my $class = shift;

    Perlbal::register_global_hook('manage_command.access', sub {
        my $mc = shift->parse(qr/^access\s+
                              (policy|allow|deny|reset|queue_low)      # cmd
                              (?:\s+(\S+))?                  # arg1
                              (?:\s+(\S+))?                  # optional arg2
                              $/x,
                              "usage: ACCESS <cmd> <arg1> [<arg2>]");
        my ($cmd, $arg1, $arg2) = $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 $ss = Perlbal->service($svcname);
        return $mc->err("Non-existent service '$svcname'") unless $ss;

        my $cfg = $ss->{extra_config}->{_access} ||= {};

        if ($cmd eq "reset") {
            $ss->{extra_config}->{_access} = {};
            return $mc->ok;
        }

        if ($cmd eq "policy") {
            return $mc->err("policy must be 'allow' or 'deny'") unless
                $arg1 =~ /^allow|deny$/;
            $cfg->{deny_default} = $arg1 eq "deny";
            return $mc->ok;
        }

        if ($cmd eq "allow" || $cmd eq "deny" || $cmd eq "queue_low") {
            my ($what, $val) = ($arg1, $arg2);
            return $mc->err("Unknown item to $cmd: '$what'") unless
                $what && ($what eq "ip" || $what eq "netmask");

            if ($what eq "netmask") {
                return $mc->err("Net::Netmask not installed")
                    unless eval { require Net::Netmask; 1; };

                $val = eval { Net::Netmask->new2($val) };
                return $mc->err("Error parsing netmask") unless $val;
            }

            my $rules = $cfg->{rules} ||= [];
            push @$rules, [ $cmd, $what, $val ];
            return $mc->ok;
        }

        return $mc->err("can't get here");
    });

    return 1;
}

# unload our global commands, clear our service object
sub unload {
    my $class = shift;
    Perlbal::unregister_global_hook('manage_command.access');
    return 1;
}

# called when we're being added to a service
sub register {
    my ($class, $svc) = @_;

    my $use_observed_ip;

    $svc->register_hook('AccessControl', 'start_http_request', sub {
        my Perlbal::ClientHTTPBase $client = shift;
        my Perlbal::HTTPHeaders $hds = $client->{req_headers};
        return 0 unless $hds;
        my $uri = $hds->request_uri;

        my $allow = sub { 0; };
        my $deny = sub {
            $client->send_response(403, "Access denied.");
            return 1;
        };

        my $queue_low = sub {
            $client->set_queue_low;
            return 0;
        };

        my $rule_action = sub {
            my $rule = shift;
            if ($rule->[0] eq "deny") {
                return $deny->();
            } elsif ($rule->[0] eq "allow") {
                return $allow->();
            } elsif ($rule->[0] eq "queue_low") {
                return $queue_low->();
            }
        };

        my $match = sub {
            my $rule = shift;
            if ($rule->[1] eq "ip") {
                my $peer_ip;
                $peer_ip = $client->observed_ip_string if $use_observed_ip;
                $peer_ip ||= $client->peer_ip_string;

                return $peer_ip eq $rule->[2];
            }

            if ($rule->[1] eq "netmask") {
                my $peer_ip;
                $peer_ip = $client->observed_ip_string if $use_observed_ip;
                $peer_ip ||= $client->peer_ip_string;

                return eval { $rule->[2]->match($peer_ip); };
            }
        };

        my $cfg = $svc->{extra_config}->{_access} ||= {};
        my $rules = $cfg->{rules} || [];
        foreach my $rule (@$rules) {
            next unless $match->($rule);
            return $rule_action->($rule)
        }

        return $deny->() if $cfg->{deny_default};
        return $allow->();
    });

    # Allow AccessControl users to specify that they would like to use the observed IP as
    # opposed to the real IP for ACL checking.
    $svc->register_setter('AccessControl', 'use_observed_ip', sub {
        my ($out, $what, $val) = @_;
        return 0 unless $what;

        $use_observed_ip = $val;

        $out->("OK") if $out;

        return 1;
    });


    return 1;
}

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

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

    my @return;

    my $cfg = $svc->{extra_config}->{_access} ||= {};
    my $rules = $cfg->{rules} || [];

    foreach my $rule (@$rules) {
        my $action = uc $rule->[0];
        my $type   = uc $rule->[1];
        my $value  = $rule->[2];
        push @return, "ACCESS $action $type $value";
    }

    my $default_action = $cfg->{deny_default} ? "DENY" : "ALLOW";
    push @return, "ACCESS POLICY $default_action";

    return @return;
}

1;