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

Diff Legend

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