[perlbal] Add ability for AccessControl plugin to test against request headers.

[mark]

[commit: http://hg.dwscoalition.org/perlbal/rev/3d1f0209a8c6]

Add ability for AccessControl plugin to test against request headers.

Patch by mark.

Files modified:

• lib/Perlbal/Plugin/AccessControl.pm

--------------------------------------------------------------------------------
diff -r 0b0a1bcf00c0 -r 3d1f0209a8c6 lib/Perlbal/Plugin/AccessControl.pm
--- a/lib/Perlbal/Plugin/AccessControl.pm	Thu Jul 30 18:27:28 2009 +0000
+++ b/lib/Perlbal/Plugin/AccessControl.pm	Fri Jul 31 00:29:17 2009 +0000
@@ -11,15 +11,17 @@ no  warnings qw(deprecated);
 #     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
+#     ACCESS {ALLOW,DENY} header:User-Agent regex          ## can use any header name
+#     ACCESS {ALLOW,DENY} header:Host regex                ## regex must be valid
+#
 # 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>]*
@@ -32,10 +34,15 @@ sub load {
         my $mc = shift->parse(qr/^access\s+
                               (policy|allow|deny|reset|queue_low)      # cmd
                               (?:\s+(\S+))?                  # arg1
-                              (?:\s+(\S+))?                  # optional arg2
+                              (?:\s+(.+))?                   # optional arg2
                               $/x,
                               "usage: ACCESS <cmd> <arg1> [<arg2>]");
         my ($cmd, $arg1, $arg2) = $mc->args;
+
+        if ( $arg2 ) {
+            $arg2 =~ s/^\s+//;
+            $arg2 =~ s/\s+$//;
+        }
 
         my $svcname;
         unless ($svcname ||= $mc->{ctx}{last_created}) {
@@ -62,7 +69,7 @@ sub load {
         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");
+                $what && ($what eq "ip" || $what eq "netmask" || $what =~ /^header:\S+$/);
 
             if ($what eq "netmask") {
                 return $mc->err("Net::Netmask not installed")
@@ -70,6 +77,14 @@ sub load {
 
                 $val = eval { Net::Netmask->new2($val) };
                 return $mc->err("Error parsing netmask") unless $val;
+            }
+
+            # compile the regular expression if we know it's going to be one
+            if ( $what =~ /^header:(\S+)$/ ) {
+                $val = qr/$val/i;
+                return $mc->err( "Invalid regular expression for $what" ) unless $val;
+
+                $what = $1;
             }
 
             my $rules = $cfg->{rules} ||= [];
@@ -141,6 +156,12 @@ sub register {
 
                 return eval { $rule->[2]->match($peer_ip); };
             }
+
+            # if we get here, we assume that 'what' is a header type object, and we
+            # can try to do a header match.
+            if ( my $val = $hds->header( $rule->[1] ) ) {
+                return $val =~ /$rule->[2]/;
+            }
         };
 
         my $cfg = $svc->{extra_config}->{_access} ||= {};
--------------------------------------------------------------------------------