ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/Coro/myhttpd/access.pl
(Generate patch)

Comparing cvsroot/Coro/myhttpd/access.pl (file contents):
Revision 1.6 by root, Sun Aug 19 23:57:52 2001 UTC vs.
Revision 1.26 by root, Tue Dec 4 15:57:59 2001 UTC

1package transferqueue;
1 2
3my @reserve = (
4 [ 1_200_000, 1],
5 [ 3_000_000, 1],
6 [ 75_000_000, 1],
7);
8
9sub new {
10 my $class = shift;
11 my $self = bless {
12 slots => $_[0],
13 lastspb => 0,
14 avgspb => 0,
15 }, $class;
16 $self->{reschedule} = Event->timer(
17 after => 10,
18 interval => 3,
19 cb => sub { $self->wake_next },
20 );
21 $self;
22}
23
24sub start_transfer {
25 my $self = shift;
26 my $size = $_[0];
27
28 my $transfer = bless {
29 queue => $self,
30 time => $::NOW,
31 size => $size,
32 coro => $Coro::current,
33 started => 0,
34 }, transfer::;
35
36 push @{$self->{wait}}, $transfer;
37
38 $self->wake_next;
39
40 $transfer;
41}
42
43sub sort {
44 my @queue = grep $_, @{$_[0]{wait}};
45
46 $_->{spb} = ($::NOW-$_->{time}) / ($_->{size} || 1) for @queue;
47
48 $_[0]{wait} = [sort { $b->{spb} <=> $a->{spb} } @queue];
49
50 Scalar::Util::weaken $_ for @{$_[0]{wait}};
51}
52
53sub wake_next {
54 my $self = shift;
55
56 $self->sort;
57
58 while (@{$self->{wait}}) {
59 my $size = $self->{wait}[0]{size};
60 my $min = 0;
61 for (@reserve) {
62 last if $size <= $_->[0];
63 $min += $_->[1];
64 }
65 last unless $self->{slots} > $min;
66 my $transfer = shift @{$self->{wait}};
67 $self->{lastspb} = $transfer->{spb};
68 $self->{avgspb} ||= $transfer->{spb};
69 $self->{avgspb} = $self->{avgspb} * 0.95 + $transfer->{spb} * 0.05;
70 $self->{started}++;
71 $transfer->wake;
72 last;
73 }
74}
75
76sub waiters {
77 $_[0]->sort;
78 @{$_[0]{wait}};
79}
80
81sub DESTROY {
82 my $self = shift;
83
84 $self->{reschedule}->cancel;
85}
86
87package transfer;
88
89use Coro::Timer ();
90
91sub wake {
92 my $self = shift;
93
94 $self->{alloc} = 1;
95 $self->{queue}{slots}--;
96 $self->{wake} and $self->{wake}->ready;
97}
98
99sub try {
100 my $self = shift;
101
102 $self->{alloc} || do {
103 my $timeout = Coro::Timer::timeout $_[0];
104 local $self->{wake} = $self->{coro};
105
106 Coro::schedule;
107
108 $self->{alloc};
109 }
110}
111
112sub DESTROY {
113 my $self = shift;
114
115 if ($self->{alloc}) {
116 $self->{queue}{slots}++;
117 $self->{queue}->wake_next;
118 }
119}
120
121package conn;
122
2our @blockuri; 123our %blockuri;
3our @blockref; 124our $blockref;
4 125
5sub read_blockuri { 126sub read_blockuri {
6 local *B; 127 local *B;
7 my %group; 128 my %group;
8 @blockuri = (); 129 %blockuri = ();
9 if (open B, "<blockuri") { 130 if (open B, "<blockuri") {
10 while (<B>) { 131 while (<B>) {
11 chomp; 132 chomp;
12 if (/^group\s+(\S+)\s+(.*)/i) { 133 if (/^group\s+(\S+)\s+(.*)/i) {
13 $group{$1} = [split /\s+/, $2]; 134 $group{$1} = [split /\s+/, $2];
… …
16 my @r; 137 my @r;
17 for (split /\s+/, $2) { 138 for (split /\s+/, $2) {
18 push @r, $group{$_} ? @{$group{$_}} : $_; 139 push @r, $group{$_} ? @{$group{$_}} : $_;
19 } 140 }
20 print "not($g) => (@r)\n"; 141 print "not($g) => (@r)\n";
142 push @{$blockuri{$_}}, $g for @r;
21 push @blockuri, [qr/$g/i, \@r]; 143 push @blockuri, [qr/$g/i, \@r];
22 } elsif (/\S/) { 144 } elsif (/\S/) {
23 print "blockuri: unparsable line: $_\n"; 145 print "blockuri: unparsable line: $_\n";
24 } 146 }
25 } 147 }
148 for (keys %blockuri) {
149 my $qr = join ")|(?:", @{$blockuri{$_}};
150 $blockuri{$_} = qr{(?:$qr)}i;
151 }
26 } else { 152 } else {
27 print "no blockuri\n"; 153 print "no blockuri\n";
28 } 154 }
29} 155}
30 156
31sub read_blockref { 157sub read_blockref {
32 local *B; 158 local *B;
33 @blockref = (); 159 my @blockref;
34 if (open B, "<blockreferer") { 160 if (open B, "<blockreferer") {
35 while (<B>) { 161 while (<B>) {
36 chomp; 162 chomp;
37 if (/^([^\t]*)\t\s*(.*)/) { 163 if (/^([^\t]*)\t\s*(.*)/) {
38 push @blockref, qr/^$1/i; 164 push @blockref, $1;
39 } elsif (/\S/) { 165 } elsif (/\S/) {
40 print "blockref: unparsable line: $_\n"; 166 print "blockref: unparsable line: $_\n";
41 } 167 }
42 } 168 }
169 $blockref = join ")|(?:", @blockref;
170 $blockref = qr{^(?:$blockref)}i;
43 } else { 171 } else {
44 print "no blockref\n"; 172 print "no blockref\n";
173 $blockref = qr{^x^};
45 } 174 }
46} 175}
47 176
48read_blockuri; 177read_blockuri;
49read_blockref; 178read_blockref;
50 179
51use Tie::Cache; 180use Tie::Cache;
52tie %whois_cache, Tie::Cache::, $MAX_CONNECTS * 1.5; 181tie %whois_cache, Tie::Cache::, 32;
53 182
54sub conn::err_block_country {
55 my $self = shift;
56 my $whois = shift;
57
58 $whois =~ s/&/&amp;/g;
59 $whois =~ s/</&lt;/g;
60 $self->err(403, "forbidden", { "Content-Type" => "text/html" }, <<EOF);
61<html>
62<head>
63<title>This material is licensed in your country!</title>
64</head>
65<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
66
67<h1>This material is licensed in your country!</h1>
68
69<p>My research has shown that your IP address
70(<b>$self->{remote_addr}</b>) most probably is located in this country:
71<b>$self->{country}</b> (ISO-3166-2 code, XX == unknown). The full record is:</p>
72
73<pre>
74$whois
75</pre>
76
77<p>My database says that the material you are trying to access is licensed
78in your country. If I would distribute these files to your country I would
79actively <em>hurt</em> the industry behind it, which includes the artists
80and authors of these videos/mangas. So I hope you understand that I try to
81avoid this.</p>
82
83<p>If you <em>really</em> think that this is wrong, i.e. the
84material you tried to access is <em>not</em> licensed in your
85country or your ip address was misdetected, you can write to <a
86href="mailto:licensed\@plan9.de">licensed\@plan9.de</a>. Please explain
87what happened and why you think this is wrong in as much detail as
88possible.</p>
89
90<div align="right">Thanks a lot for understanding.</div>
91
92</body>
93</html>
94EOF
95}
96
97sub conn::err_block_referer {
98 my $self = shift;
99
100 my $uri = $self->{uri};
101 $uri =~ s/\/[^\/]+$/\//;
102 $uri = escape_uri $uri;
103 print "hiho $uri\n";#d#
104
105 $self->slog(6, "REFERER($self->{uri},$self->{h}{referer})");
106
107 $whois =~ s/&/&amp;/g;
108 $whois =~ s/</&lt;/g;
109 $self->err(203, "non-authoritative", { "Content-Type" => "text/html" }, <<EOF);
110<html>
111<head>
112<title>Unallowed Referral</title>
113</head>
114<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
115
116<h1>The site which referred you has done something bad!</h1>
117
118<p>It seems that you are coming from this URL:</p>
119
120<pre>$self->{h}{referer}</pre>
121
122<p>This site has been blocked, either because it required you to pay
123money, forced you to click on banners, claimed these files were theirs
124or something very similar. Please note that you can download these files
125<em>without</em> having to pay, <em>without</em> clicking banners or jump
126through other hoops.</p>
127
128<p><b>Sites like the one you came from actively hurt the distribution of
129these files and the service quality for you since I can't move or correct
130files and you will likely not be able to see the full archive.</b></p>
131
132<p>Having that this, you can find the original content (if it is still
133there) by <b>following <a href="$uri">this link</a>.</b></p>
134
135<div align="right">Thanks a lot for understanding.</div>
136
137</body>
138</html>
139EOF
140}
141
142sub conn::access_check { 183sub access_check {
143 my $self = shift; 184 my $self = shift;
144 185
145 my $ref = $self->{h}{referer}; 186 my $ref = $self->{h}{referer};
146 my $uri = $self->{path}; 187 my $uri = $self->{path};
147 my %disallow; 188 my %disallow;
148 189
149 for (@blockref) {
150 $self->err_block_referer if $ref =~ $_; 190 $self->err_block_referer
151 } 191 if $self->{h}{referer} =~ $blockref;
152 192
153 for (@blockuri) {
154 if ($uri =~ $_->[0]) {
155 $disallow{$_}++ for @{$_->[1]};
156 }
157 }
158
159 my $whois = $whois_cache{$self->{remote_addr}} 193 my $whois = $whois_cache{$self->{remote_addr}}
160 ||= ::ip_request($self->{remote_addr}); 194 ||= netgeo::ip_request($self->{remote_addr});
161 195
162 my $country = "XX"; 196 my $country = "XX";
163 197
164 if ($whois =~ /^\*cy: (\S+)/m) { 198 if ($whois =~ /^\*cy: (\S+)/m) {
165 $country = uc $1; 199 $country = uc $1;
… …
167 $self->slog(9, "no country($whois)"); 201 $self->slog(9, "no country($whois)");
168 } 202 }
169 203
170 $self->{country} = $country; 204 $self->{country} = $country;
171 205
172 if ($disallow{$country}) {
173 $self->err_block_country($whois); 206 $self->err_block_country($whois)
174 } 207 if $self->{path} =~ $blockuri{$country};
175} 208}
176 209
1771; 2101;

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines