Coro/myhttpd/access.pl

package transferqueue;

my @reserve = (
      [  1_200_000, 2],
      [  8_000_000, 1],
      [ 75_000_000, 1],
);

sub new {
   my $class = shift;
   my $self = bless {
      slots   => 1,
      maxsize => 0,
      lastspb => 0,
      avgspb  => 0,
      @_,
   }, $class;
   $self->{reschedule} = Event->timer(
         after => 10,
         interval => 3,
         cb => sub { $self->wake_next },
   );
   $self;
}

sub start_transfer {
   my $self = shift;
   my $size = $_[0];

   if ($self->{maxsize} && $self->{maxsize} < $size) {
      $size = $self->{maxsize};
   }

   my $transfer = bless {
      queue   => $self,
      time    => $::NOW,
      size    => $size,
      coro    => $Coro::current,
      started => 0,
   }, transfer::;

   push @{$self->{wait}}, $transfer;

   $self->wake_next;

   $transfer;
}

sub sort {
   my @queue = grep $_, @{$_[0]{wait}};

   $_->{spb} = ($::NOW-$_->{time}) / ($_->{size} || 1) for @queue;
   
   $_[0]{wait} = [sort { $b->{spb} <=> $a->{spb} } @queue];

   Scalar::Util::weaken $_ for @{$_[0]{wait}};
}

sub wake_next {
   my $self = shift;

   $self->sort;

   while (@{$self->{wait}}) {
      my $size = $self->{wait}[0]{size};
      my $min = 0;
      for (@reserve) {
         last if $size <= $_->[0];
         $min += $_->[1];
      }
      last unless $self->{slots} > $min;
      my $transfer = shift @{$self->{wait}};
      $self->{lastspb} = $transfer->{spb};
      $self->{avgspb} = $self->{avgspb} * 0.99 + $transfer->{spb} * 0.01;
      $self->{started}++;
      $transfer->wake;
      last;
   }
}

sub waiters {
   $_[0]->sort;
   @{$_[0]{wait}};
}

sub DESTROY {
   my $self = shift;

   $self->{reschedule}->cancel;
}

package transfer;

use Coro::Timer ();

sub wake {
   my $self = shift;

   $self->{alloc} = 1;
   $self->{queue}{slots}--;
   $self->{wake} and $self->{wake}->ready;
}

sub try {
   my $self = shift;

   $self->{alloc} || do {
      my $timeout = Coro::Timer::timeout $_[0];
      local $self->{wake} = $self->{coro};

      Coro::schedule;

      $self->{alloc};
   }
}

sub DESTROY {
   my $self = shift;

   if ($self->{alloc}) {
      $self->{queue}{slots}++;
      $self->{queue}->wake_next;
   }
}

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.28
Committed:	Thu Jan 3 01:20:17 2002 UTC (22 years, 6 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.27:	+7 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.11	package transferqueue;
2
3	root	1.24	my @reserve = (
4	root	1.27	[ 1_200_000, 2],
5			[ 8_000_000, 1],
6	root	1.25	[ 75_000_000, 1],
7	root	1.24	);
8
9	root	1.11	sub new {
10			my $class = shift;
11	root	1.26	my $self = bless {
12	root	1.28	slots => 1,
13			maxsize => 0,
14	root	1.19	lastspb => 0,
15	root	1.20	avgspb => 0,
16	root	1.28	@_,
17	root	1.11	}, $class;
18	root	1.26	$self->{reschedule} = Event->timer(
19			after => 10,
20			interval => 3,
21			cb => sub { $self->wake_next },
22			);
23			$self;
24	root	1.11	}
25
26			sub start_transfer {
27			my $self = shift;
28	root	1.19	my $size = $_[0];
29	root	1.28
30			if ($self->{maxsize} && $self->{maxsize} < $size) {
31			$size = $self->{maxsize};
32			}
33	root	1.11
34	root	1.20	my $transfer = bless {
35	root	1.22	queue => $self,
36			time => $::NOW,
37			size => $size,
38			coro => $Coro::current,
39			started => 0,
40	root	1.19	}, transfer::;
41	root	1.11
42	root	1.20	push @{$self->{wait}}, $transfer;
43	root	1.11
44	root	1.19	$self->wake_next;
45	root	1.11
46	root	1.22	$transfer;
47			}
48
49			sub sort {
50			my @queue = grep $_, @{$_[0]{wait}};
51
52			$_->{spb} = ($::NOW-$_->{time}) / ($_->{size} \|\| 1) for @queue;
53
54			$_[0]{wait} = [sort { $b->{spb} <=> $a->{spb} } @queue];
55
56			Scalar::Util::weaken $_ for @{$_[0]{wait}};
57	root	1.11	}
58
59			sub wake_next {
60			my $self = shift;
61
62	root	1.19	$self->sort;
63
64	root	1.24	while (@{$self->{wait}}) {
65			my $size = $self->{wait}[0]{size};
66			my $min = 0;
67			for (@reserve) {
68			last if $size <= $_->[0];
69			$min += $_->[1];
70			}
71			last unless $self->{slots} > $min;
72	root	1.18	my $transfer = shift @{$self->{wait}};
73	root	1.24	$self->{lastspb} = $transfer->{spb};
74	root	1.27	$self->{avgspb} = $self->{avgspb} * 0.99 + $transfer->{spb} * 0.01;
75	root	1.24	$self->{started}++;
76			$transfer->wake;
77			last;
78	root	1.13	}
79	root	1.19	}
80
81	root	1.11	sub waiters {
82	root	1.19	$_[0]->sort;
83			@{$_[0]{wait}};
84	root	1.26	}
85
86			sub DESTROY {
87			my $self = shift;
88
89			$self->{reschedule}->cancel;
90	root	1.11	}
91
92			package transfer;
93
94			use Coro::Timer ();
95
96	root	1.16	sub wake {
97			my $self = shift;
98	root	1.19
99			$self->{alloc} = 1;
100			$self->{queue}{slots}--;
101			$self->{wake} and $self->{wake}->ready;
102	root	1.16	}
103
104	root	1.11	sub try {
105			my $self = shift;
106
107	root	1.19	$self->{alloc} \|\| do {
108	root	1.16	my $timeout = Coro::Timer::timeout $_[0];
109	root	1.19	local $self->{wake} = $self->{coro};
110	root	1.16
111	root	1.15	Coro::schedule;
112	root	1.19
113			$self->{alloc};
114	root	1.15	}
115	root	1.11	}
116
117			sub DESTROY {
118			my $self = shift;
119	root	1.19
120			if ($self->{alloc}) {
121			$self->{queue}{slots}++;
122			$self->{queue}->wake_next;
123			}
124	root	1.11	}
125
126	root	1.8	package conn;
127	root	1.1
128	root	1.8	our %blockuri;
129			our $blockref;
130	root	1.1
131	root	1.6	sub read_blockuri {
132	root	1.1	local *B;
133			my %group;
134	root	1.8	%blockuri = ();
135	root	1.6	if (open B, "<blockuri") {
136	root	1.1	while (<B>) {
137			chomp;
138			if (/^group\s+(\S+)\s+(.*)/i) {
139			$group{$1} = [split /\s+/, $2];
140			} elsif (/^!([^\t])\t\s(.*)/) {
141			my $g = $1;
142			my @r;
143			for (split /\s+/, $2) {
144			push @r, $group{$_} ? @{$group{$_}} : $_;
145			}
146			print "not($g) => (@r)\n";
147	root	1.8	push @{$blockuri{$_}}, $g for @r;
148	root	1.6	push @blockuri, [qr/$g/i, \@r];
149	root	1.1	} elsif (/\S/) {
150	root	1.6	print "blockuri: unparsable line: $_\n";
151	root	1.1	}
152			}
153	root	1.8	for (keys %blockuri) {
154			my $qr = join ")\|(?:", @{$blockuri{$_}};
155			$blockuri{$_} = qr{(?:$qr)}i;
156			}
157	root	1.1	} else {
158	root	1.6	print "no blockuri\n";
159	root	1.1	}
160			}
161
162	root	1.6	sub read_blockref {
163			local *B;
164	root	1.8	my @blockref;
165	root	1.6	if (open B, "<blockreferer") {
166			while (<B>) {
167			chomp;
168			if (/^([^\t])\t\s(.*)/) {
169	root	1.8	push @blockref, $1;
170	root	1.6	} elsif (/\S/) {
171			print "blockref: unparsable line: $_\n";
172			}
173			}
174	root	1.8	$blockref = join ")\|(?:", @blockref;
175			$blockref = qr{^(?:$blockref)}i;
176	root	1.6	} else {
177			print "no blockref\n";
178	root	1.8	$blockref = qr{^x^};
179	root	1.6	}
180			}
181
182			read_blockuri;
183			read_blockref;
184	root	1.1
185	root	1.5	use Tie::Cache;
186	root	1.10	tie %whois_cache, Tie::Cache::, 32;
187	root	1.1
188	root	1.8	sub access_check {
189	root	1.6	my $self = shift;
190
191			my $ref = $self->{h}{referer};
192			my $uri = $self->{path};
193			my %disallow;
194
195	root	1.8	$self->err_block_referer
196			if $self->{h}{referer} =~ $blockref;
197	root	1.6
198			my $whois = $whois_cache{$self->{remote_addr}}
199	root	1.9	\|\|= netgeo::ip_request($self->{remote_addr});
200	root	1.6
201			my $country = "XX";
202
203			if ($whois =~ /^\*cy: (\S+)/m) {
204			$country = uc $1;
205			} else {
206			$self->slog(9, "no country($whois)");
207			}
208
209			$self->{country} = $country;
210
211	root	1.8	$self->err_block_country($whois)
212			if $self->{path} =~ $blockuri{$country};
213	root	1.1	}
214
215			1;