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

Diff Legend

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