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

Diff Legend

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