Coro/myhttpd/access.pl

package transferqueue;

sub new {
   my $class = shift;
   bless {
      conns => $_[0],
   }, $class;
}

sub start_transfer {
   my $self = shift;

   my $trans = bless [ $self ], transfer::;

   push @{$self->{wait}}, $trans;
   Scalar::Util::weaken($self->{wait}[-1]);

   print "ALLOC $Coro::current\n";#d#
   --$self->{conns};
   $self->wake_next;

   $trans;
}

sub wake_next {
   my $self = shift;

   while ($self->{conns} >= 0 && @{$self->{wait}}) {
            print "WAKING some\n";#d#
      while(@{$self->{wait}}) {
         my $transfer = shift @{$self->{wait}};
         if ($transfer) {
            print "WAKING $transfer\n";#d#
            $transfer->wake;
            last;
         }
      }
   }
}

sub waiters {
   map $_->[1], @{$_[0]{wait}};
}

package transfer;

use Coro::Timer ();

sub wake {
   my $self = shift;
   $self->[2] = 1;
   ref $self->[1] and $self->[1]->ready;
}

sub try {
   my $self = shift;

   unless ($self->[2]) {
      my $timeout = Coro::Timer::timeout $_[0];
      local $self->[1] = $Coro::current;

      Coro::schedule;
      print "WOKE $Coro::current\n" if $self->[2];
   }

   return $self->[2];
}

sub DESTROY {
   my $self = shift;
   eval {
   $self->[0]{conns}++;
   $self->[0]->wake_next;
   };
   print "DESTROY $Coro::current $@\n";#d#
}

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 $whois = $whois_cache{$self->{remote_addr}}
               ||= netgeo::ip_request($self->{remote_addr});

   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.17
Committed:	Sat Dec 1 01:09:56 2001 UTC (22 years, 7 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.16:	+9 -5 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.11	package transferqueue;
2
3			sub new {
4			my $class = shift;
5			bless {
6			conns => $_[0],
7			}, $class;
8			}
9
10			sub start_transfer {
11			my $self = shift;
12
13	root	1.15	my $trans = bless [ $self ], transfer::;
14	root	1.11
15			push @{$self->{wait}}, $trans;
16	root	1.13	Scalar::Util::weaken($self->{wait}[-1]);
17	root	1.11
18	root	1.17	print "ALLOC $Coro::current\n";#d#
19	root	1.16	--$self->{conns};
20			$self->wake_next;
21	root	1.11
22			$trans;
23			}
24
25			sub wake_next {
26			my $self = shift;
27
28	root	1.17	while ($self->{conns} >= 0 && @{$self->{wait}}) {
29			print "WAKING some\n";#d#
30	root	1.14	while(@{$self->{wait}}) {
31	root	1.13	my $transfer = shift @{$self->{wait}};
32			if ($transfer) {
33	root	1.17	print "WAKING $transfer\n";#d#
34	root	1.13	$transfer->wake;
35			last;
36			}
37			}
38			}
39	root	1.11	}
40
41			sub waiters {
42			map $_->[1], @{$_[0]{wait}};
43			}
44
45			package transfer;
46
47			use Coro::Timer ();
48
49	root	1.16	sub wake {
50			my $self = shift;
51			$self->[2] = 1;
52			ref $self->[1] and $self->[1]->ready;
53			}
54
55	root	1.11	sub try {
56			my $self = shift;
57
58	root	1.15	unless ($self->[2]) {
59	root	1.16	my $timeout = Coro::Timer::timeout $_[0];
60	root	1.17	local $self->[1] = $Coro::current;
61	root	1.16
62	root	1.15	Coro::schedule;
63	root	1.17	print "WOKE $Coro::current\n" if $self->[2];
64	root	1.15	}
65	root	1.11
66			return $self->[2];
67			}
68
69			sub DESTROY {
70			my $self = shift;
71	root	1.17	eval {
72	root	1.11	$self->[0]{conns}++;
73			$self->[0]->wake_next;
74	root	1.17	};
75			print "DESTROY $Coro::current $@\n";#d#
76	root	1.11	}
77
78	root	1.8	package conn;
79	root	1.1
80	root	1.8	our %blockuri;
81			our $blockref;
82	root	1.1
83	root	1.6	sub read_blockuri {
84	root	1.1	local *B;
85			my %group;
86	root	1.8	%blockuri = ();
87	root	1.6	if (open B, "<blockuri") {
88	root	1.1	while (<B>) {
89			chomp;
90			if (/^group\s+(\S+)\s+(.*)/i) {
91			$group{$1} = [split /\s+/, $2];
92			} elsif (/^!([^\t])\t\s(.*)/) {
93			my $g = $1;
94			my @r;
95			for (split /\s+/, $2) {
96			push @r, $group{$_} ? @{$group{$_}} : $_;
97			}
98			print "not($g) => (@r)\n";
99	root	1.8	push @{$blockuri{$_}}, $g for @r;
100	root	1.6	push @blockuri, [qr/$g/i, \@r];
101	root	1.1	} elsif (/\S/) {
102	root	1.6	print "blockuri: unparsable line: $_\n";
103	root	1.1	}
104			}
105	root	1.8	for (keys %blockuri) {
106			my $qr = join ")\|(?:", @{$blockuri{$_}};
107			$blockuri{$_} = qr{(?:$qr)}i;
108			}
109	root	1.1	} else {
110	root	1.6	print "no blockuri\n";
111	root	1.1	}
112			}
113
114	root	1.6	sub read_blockref {
115			local *B;
116	root	1.8	my @blockref;
117	root	1.6	if (open B, "<blockreferer") {
118			while (<B>) {
119			chomp;
120			if (/^([^\t])\t\s(.*)/) {
121	root	1.8	push @blockref, $1;
122	root	1.6	} elsif (/\S/) {
123			print "blockref: unparsable line: $_\n";
124			}
125			}
126	root	1.8	$blockref = join ")\|(?:", @blockref;
127			$blockref = qr{^(?:$blockref)}i;
128	root	1.6	} else {
129			print "no blockref\n";
130	root	1.8	$blockref = qr{^x^};
131	root	1.6	}
132			}
133
134			read_blockuri;
135			read_blockref;
136	root	1.1
137	root	1.5	use Tie::Cache;
138	root	1.10	tie %whois_cache, Tie::Cache::, 32;
139	root	1.1
140	root	1.8	sub access_check {
141	root	1.6	my $self = shift;
142
143			my $ref = $self->{h}{referer};
144			my $uri = $self->{path};
145			my %disallow;
146
147	root	1.8	$self->err_block_referer
148			if $self->{h}{referer} =~ $blockref;
149	root	1.6
150			my $whois = $whois_cache{$self->{remote_addr}}
151	root	1.9	\|\|= netgeo::ip_request($self->{remote_addr});
152	root	1.6
153			my $country = "XX";
154
155			if ($whois =~ /^\*cy: (\S+)/m) {
156			$country = uc $1;
157			} else {
158			$self->slog(9, "no country($whois)");
159			}
160
161			$self->{country} = $country;
162
163	root	1.8	$self->err_block_country($whois)
164			if $self->{path} =~ $blockuri{$country};
165	root	1.1	}
166
167			1;