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

Diff Legend

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