Coro/myhttpd/access.pl

package transferqueue;

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

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

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

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

   $self->wake_next;

   $trans;
}

sub wake_next {
   my $self = shift;

   $self->sort;

   while($self->{slots} && @{$self->{wait}}) {
      my $transfer = shift @{$self->{wait}};
      if ($transfer) {
         $self->{lastspb} = $transfer->{spb};
         $self->{avgspb} ||= $transfer->{spb};
         $self->{avgspb} = $self->{avgspb} * 0.95 + $transfer->{spb} * 0.05;
         $transfer->wake;
         last;
      }
   }
}

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

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

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

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