Patch by mark.
diffs (78 lines):
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} ||= {};
_______________________________________________
dw-changelog mailing list
[email protected]
http://lists.dwscoalition.org/mailman/listinfo/dw-changelog
