Coro/myhttpd/access.pl

package conn;

our %blockuri;
our $blockref;

sub read_blockuri {
   local *B;
   my %group;
   %blockuri = ();
   if (open B, "<blockuri") {
      while (<B>) {
         chomp;
         if (/^group\s+(\S+)\s+(.*)/i) {
            $group{$1} = [split /\s+/, $2];
         } elsif (/^!([^\t]*)\t\s*(.*)/) {
            my $g = $1;
            my @r;
            for (split /\s+/, $2) {
               push @r, $group{$_} ? @{$group{$_}} : $_;
            }
            print "not($g) => (@r)\n";
            push @{$blockuri{$_}}, $g for @r;
            push @blockuri, [qr/$g/i, \@r];
         } elsif (/\S/) {
            print "blockuri: unparsable line: $_\n";
         }
      }
      for (keys %blockuri) {
         my $qr = join ")|(?:", @{$blockuri{$_}};
         $blockuri{$_} = qr{(?:$qr)}i;
      }
   } else {
      print "no blockuri\n";
   }
}

sub read_blockref {
   local *B;
   my @blockref;
   if (open B, "<blockreferer") {
      while (<B>) {
         chomp;
         if (/^([^\t]*)\t\s*(.*)/) {
            push @blockref, $1;
         } elsif (/\S/) {
            print "blockref: unparsable line: $_\n";
         }
      }
      $blockref = join ")|(?:", @blockref;
      $blockref = qr{^(?:$blockref)}i;
   } else {
      print "no blockref\n";
      $blockref = qr{^x^};
   }
}

read_blockuri;
read_blockref;

use Tie::Cache;
tie %whois_cache, Tie::Cache::, 32;

sub access_check {
   my $self = shift;

   my $ref = $self->{h}{referer};
   my $uri = $self->{path};
   my %disallow;

   $self->err_block_referer
      if $self->{h}{referer} =~ $blockref;

   my $ra = $self->{remote_addr};
   my $whois = $whois_cache{$ra} ||= netgeo::ip_request($ra);

   my $country = "XX";

   if ($whois =~ /^\*cy: (\S+)/m) {
      $country = uc $1;
   } else {
      $self->slog(9, "no country($whois)");
   }

   $self->{country} = $country;

   $self->err_block_country($whois)
      if $self->{path} =~ $blockuri{$country};
}

1;
Revision:	1.31
Committed:	Thu Nov 21 09:52:34 2002 UTC (21 years, 7 months ago) by root
Content type:	text/plain
Branch:	MAIN
CVS Tags:	rel-2_5, rel-4_91, rel-4_22, rel-4_21, rel-4_0, rel-4_3, rel-3_41, rel-5_151, rel-4_13, rel-4_11, rel-5_1, rel-5_0, rel-6_0, rel-6_5, rel-4_748, rel-3_55, rel-4_8, rel-4_9, rel-3_51, rel-4_741, rel-4_743, rel-4_742, rel-6_10, rel-4_744, rel-4_747, rel-6_13, rel-4_01, rel-4_03, rel-4_02, rel-2_0, rel-2_1, rel-1_1, rel-1_0, rel-1_9, rel-1_2, rel-3_6, rel-3_62, rel-3_63, rel-3_61, rel-1_5, rel-1_4, rel-1_7, rel-1_6, rel-3_4, rel-6_09, rel-6_08, rel-6_07, rel-6_06, rel-6_05, rel-6_04, rel-6_03, rel-6_02, rel-6_01, rel-5_161, rel-3_1, rel-4_74, rel-4_71, rel-4_72, rel-4_73, rel-5_371, rel-5_372, rel-6_512, rel-6_513, rel-6_511, rel-6_514, rel-5_22, rel-5_23, rel-5_24, rel-5_25, rel-6_32, rel-6_33, rel-6_31, rel-6_36, rel-6_37, rel-5_162, rel-5_2, rel-6_38, rel-6_39, rel-4_802, rel-4_803, rel-3_5, rel-4_801, rel-3_3, rel-3_2, rel-4_804, rel-3_0, rel-5_37, rel-5_36, rel-4_479, rel-6_23, rel-3_01, rel-6_29, rel-6_28, rel-6_46, rel-4_50, rel-4_51, rel-6_45, rel-4_4, rel-3_11, rel-1_31, rel-4_45, rel-6_51, rel-6_52, rel-6_53, rel-6_54, rel-6_55, rel-6_56, rel-6_57, rel-4_745, rel-4_901, rel-4_49, rel-4_48, rel-4_1, rel-4_2, rel-4_746, rel-5_11, rel-5_12, rel-5_15, rel-5_14, rel-5_17, rel-5_16, stack_sharing, rel-4_47, rel-4_46, rel-4_7, rel-3_501, rel-6_43, rel-6_42, rel-6_41, rel-6_47, rel-5_132, rel-5_131, rel-6_44, rel-6_49, rel-6_48, rel-4_911, rel-4_912, rel-4_31, rel-4_32, rel-4_33, rel-4_34, rel-4_35, rel-4_36, rel-4_37, HEAD
Changes since 1.30:	+2 -2 lines
Log Message:	config.pl.dist
#	User	Rev	Content
1	root	1.8	package conn;
2	root	1.1
3	root	1.8	our %blockuri;
4			our $blockref;
5	root	1.1
6	root	1.6	sub read_blockuri {
7	root	1.1	local *B;
8			my %group;
9	root	1.8	%blockuri = ();
10	root	1.6	if (open B, "<blockuri") {
11	root	1.1	while (<B>) {
12			chomp;
13			if (/^group\s+(\S+)\s+(.*)/i) {
14			$group{$1} = [split /\s+/, $2];
15			} elsif (/^!([^\t])\t\s(.*)/) {
16			my $g = $1;
17			my @r;
18			for (split /\s+/, $2) {
19			push @r, $group{$_} ? @{$group{$_}} : $_;
20			}
21			print "not($g) => (@r)\n";
22	root	1.8	push @{$blockuri{$_}}, $g for @r;
23	root	1.6	push @blockuri, [qr/$g/i, \@r];
24	root	1.1	} elsif (/\S/) {
25	root	1.6	print "blockuri: unparsable line: $_\n";
26	root	1.1	}
27			}
28	root	1.8	for (keys %blockuri) {
29			my $qr = join ")\|(?:", @{$blockuri{$_}};
30			$blockuri{$_} = qr{(?:$qr)}i;
31			}
32	root	1.1	} else {
33	root	1.6	print "no blockuri\n";
34	root	1.1	}
35			}
36
37	root	1.6	sub read_blockref {
38			local *B;
39	root	1.8	my @blockref;
40	root	1.6	if (open B, "<blockreferer") {
41			while (<B>) {
42			chomp;
43			if (/^([^\t])\t\s(.*)/) {
44	root	1.8	push @blockref, $1;
45	root	1.6	} elsif (/\S/) {
46			print "blockref: unparsable line: $_\n";
47			}
48			}
49	root	1.8	$blockref = join ")\|(?:", @blockref;
50			$blockref = qr{^(?:$blockref)}i;
51	root	1.6	} else {
52			print "no blockref\n";
53	root	1.8	$blockref = qr{^x^};
54	root	1.6	}
55			}
56
57			read_blockuri;
58			read_blockref;
59	root	1.1
60	root	1.5	use Tie::Cache;
61	root	1.10	tie %whois_cache, Tie::Cache::, 32;
62	root	1.1
63	root	1.8	sub access_check {
64	root	1.6	my $self = shift;
65
66			my $ref = $self->{h}{referer};
67			my $uri = $self->{path};
68			my %disallow;
69
70	root	1.8	$self->err_block_referer
71			if $self->{h}{referer} =~ $blockref;
72	root	1.6
73	root	1.31	my $ra = $self->{remote_addr};
74			my $whois = $whois_cache{$ra} \|\|= netgeo::ip_request($ra);
75	root	1.6
76			my $country = "XX";
77
78			if ($whois =~ /^\*cy: (\S+)/m) {
79			$country = uc $1;
80			} else {
81			$self->slog(9, "no country($whois)");
82			}
83
84			$self->{country} = $country;
85
86	root	1.8	$self->err_block_country($whois)
87			if $self->{path} =~ $blockuri{$country};
88	root	1.1	}
89
90			1;