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

Comparing Coro/myhttpd/access.pl (file contents):
Revision 1.7 by root, Mon Aug 20 16:58:19 2001 UTC vs.
Revision 1.14 by root, Fri Nov 30 03:02:23 2001 UTC

1package transferqueue;
1 2
3sub new {
4 my $class = shift;
5 bless {
6 conns => $_[0],
7 }, $class;
8}
9
10sub start_transfer {
11 my $self = shift;
12
13 my $trans = bless [ $self, $Coro::current ], transfer::;
14 Scalar::Util::weaken($trans->[0]);
15
16 push @{$self->{wait}}, $trans;
17 Scalar::Util::weaken($self->{wait}[-1]);
18
19 if (--$self->{conns} >= 0) {
20 $self->wake_next;
21 }
22
23 $trans;
24}
25
26sub wake_next {
27 my $self = shift;
28
29 if ($self->{conns} >= 0) {
30 while(@{$self->{wait}}) {
31 my $transfer = shift @{$self->{wait}};
32 if ($transfer) {
33 $transfer->wake;
34 last;
35 }
36 }
37 }
38}
39
40sub waiters {
41 map $_->[1], @{$_[0]{wait}};
42}
43
44package transfer;
45
46use Coro::Timer ();
47
48sub try {
49 my $self = shift;
50 my $timeout = Coro::Timer::timeout $_[0];
51
52 $self->[2] or Coro::schedule;
53
54 return $self->[2];
55}
56
57sub wake {
58 my $self = shift;
59 $self->[2] = 1;
60 $self->[1]->ready;
61}
62
63sub DESTROY {
64 my $self = shift;
65 $self->[0]{conns}++;
66 $self->[0]->wake_next;
67}
68
69package conn;
70
2our @blockuri; 71our %blockuri;
3our @blockref; 72our $blockref;
4 73
5sub read_blockuri { 74sub read_blockuri {
6 local *B; 75 local *B;
7 my %group; 76 my %group;
8 @blockuri = (); 77 %blockuri = ();
9 if (open B, "<blockuri") { 78 if (open B, "<blockuri") {
10 while (<B>) { 79 while (<B>) {
11 chomp; 80 chomp;
12 if (/^group\s+(\S+)\s+(.*)/i) { 81 if (/^group\s+(\S+)\s+(.*)/i) {
13 $group{$1} = [split /\s+/, $2]; 82 $group{$1} = [split /\s+/, $2];
… …
16 my @r; 85 my @r;
17 for (split /\s+/, $2) { 86 for (split /\s+/, $2) {
18 push @r, $group{$_} ? @{$group{$_}} : $_; 87 push @r, $group{$_} ? @{$group{$_}} : $_;
19 } 88 }
20 print "not($g) => (@r)\n"; 89 print "not($g) => (@r)\n";
90 push @{$blockuri{$_}}, $g for @r;
21 push @blockuri, [qr/$g/i, \@r]; 91 push @blockuri, [qr/$g/i, \@r];
22 } elsif (/\S/) { 92 } elsif (/\S/) {
23 print "blockuri: unparsable line: $_\n"; 93 print "blockuri: unparsable line: $_\n";
24 } 94 }
95 }
96 for (keys %blockuri) {
97 my $qr = join ")|(?:", @{$blockuri{$_}};
98 $blockuri{$_} = qr{(?:$qr)}i;
25 } 99 }
26 } else { 100 } else {
27 print "no blockuri\n"; 101 print "no blockuri\n";
28 } 102 }
29} 103}
30 104
31sub read_blockref { 105sub read_blockref {
32 local *B; 106 local *B;
33 @blockref = (); 107 my @blockref;
34 if (open B, "<blockreferer") { 108 if (open B, "<blockreferer") {
35 while (<B>) { 109 while (<B>) {
36 chomp; 110 chomp;
37 if (/^([^\t]*)\t\s*(.*)/) { 111 if (/^([^\t]*)\t\s*(.*)/) {
38 push @blockref, qr/^$1/i; 112 push @blockref, $1;
39 } elsif (/\S/) { 113 } elsif (/\S/) {
40 print "blockref: unparsable line: $_\n"; 114 print "blockref: unparsable line: $_\n";
41 } 115 }
42 } 116 }
117 $blockref = join ")|(?:", @blockref;
118 $blockref = qr{^(?:$blockref)}i;
43 } else { 119 } else {
44 print "no blockref\n"; 120 print "no blockref\n";
121 $blockref = qr{^x^};
45 } 122 }
46} 123}
47 124
48read_blockuri; 125read_blockuri;
49read_blockref; 126read_blockref;
50 127
51use Tie::Cache; 128use Tie::Cache;
52tie %whois_cache, Tie::Cache::, $MAX_CONNECTS * 1.5; 129tie %whois_cache, Tie::Cache::, 32;
53 130
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", Connection => "close" }, <<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>Please see the <a href="http://www.goof.com/pcg/marc/animefaq.html#licensed">FAQ</a>
84for a more thorough explanation.</p>
85
86<p>If you <em>really</em> think that this is wrong, i.e. the
87material you tried to access is <em>not</em> licensed in your
88country or your ip address was misdetected, you can write to <a
89href="mailto:licensed\@plan9.de">licensed\@plan9.de</a>. Please explain
90what happened and why you think this is wrong in as much detail as
91possible.</p>
92
93<div align="right">Thanks a lot for understanding.</div>
94
95</body>
96</html>
97EOF
98}
99
100sub conn::err_block_referer {
101 my $self = shift;
102
103 my $uri = $self->{uri};
104 $uri =~ s/\/[^\/]+$/\//;
105
106 $self->slog(6, "REFERER($self->{uri},$self->{h}{referer})");
107
108 $whois =~ s/&/&amp;/g;
109 $whois =~ s/</&lt;/g;
110 $self->err(203, "non-authoritative", { "Content-Type" => "text/html" }, <<EOF);
111<html>
112<head>
113<title>Unallowed Referral</title>
114</head>
115<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
116
117<h1>The site which referred you has done something bad!</h1>
118
119<p>It seems that you are coming from this URL:</p>
120
121<pre>$self->{h}{referer}</pre>
122
123<p>This site has been blocked, either because it required you to pay
124money, forced you to click on banners, claimed these files were theirs
125or something very similar. Please note that you can download these files
126<em>without</em> having to pay, <em>without</em> clicking banners or jump
127through other hoops.</p>
128
129<p><b>Sites like the one you came from actively hurt the distribution of
130these files and the service quality for you since I can't move or correct
131files and you will likely not be able to see the full archive.</b></p>
132
133<p>Having that this, you can find the original content (if it is still
134there) by <b>following <a href="$uri">this link</a>.</b></p>
135
136<div align="right">Thanks a lot for understanding.</div>
137
138</body>
139</html>
140EOF
141}
142
143sub conn::access_check { 131sub access_check {
144 my $self = shift; 132 my $self = shift;
145 133
146 my $ref = $self->{h}{referer}; 134 my $ref = $self->{h}{referer};
147 my $uri = $self->{path}; 135 my $uri = $self->{path};
148 my %disallow; 136 my %disallow;
149 137
150 for (@blockref) {
151 $self->err_block_referer if $ref =~ $_; 138 $self->err_block_referer
152 } 139 if $self->{h}{referer} =~ $blockref;
153 140
154 for (@blockuri) {
155 if ($uri =~ $_->[0]) {
156 $disallow{$_}++ for @{$_->[1]};
157 }
158 }
159
160 my $whois = $whois_cache{$self->{remote_addr}} 141 my $whois = $whois_cache{$self->{remote_addr}}
161 ||= ::ip_request($self->{remote_addr}); 142 ||= netgeo::ip_request($self->{remote_addr});
162 143
163 my $country = "XX"; 144 my $country = "XX";
164 145
165 if ($whois =~ /^\*cy: (\S+)/m) { 146 if ($whois =~ /^\*cy: (\S+)/m) {
166 $country = uc $1; 147 $country = uc $1;
… …
168 $self->slog(9, "no country($whois)"); 149 $self->slog(9, "no country($whois)");
169 } 150 }
170 151
171 $self->{country} = $country; 152 $self->{country} = $country;
172 153
173 if ($disallow{$country}) {
174 $self->err_block_country($whois); 154 $self->err_block_country($whois)
175 } 155 if $self->{path} =~ $blockuri{$country};
176} 156}
177 157
1781; 1581;

Diff Legend

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