Coro/myhttpd/access.pl


our @blockuri;
our @blockref;

sub read_blockuri {
   local *B;
   my %group;
   @blockuri = ();
   if (open B, "<blockuri") {
      while (<B>) {
         chomp;
         if (/^group\s+(\S+)\s+(.*)/i) {
            $group{$1} = [split /\s+/, $2];
         } elsif (/^!([^\t]*)\t\s*(.*)/) {
            my $g = $1;
            my @r;
            for (split /\s+/, $2) {
               push @r, $group{$_} ? @{$group{$_}} : $_;
            }
            print "not($g) => (@r)\n";
            push @blockuri, [qr/$g/i, \@r];
         } elsif (/\S/) {
            print "blockuri: unparsable line: $_\n";
         }
      }
   } else {
      print "no blockuri\n";
   }
}

sub read_blockref {
   local *B;
   @blockref = ();
   if (open B, "<blockreferer") {
      while (<B>) {
         chomp;
         if (/^([^\t]*)\t\s*(.*)/) {
            push @blockref, qr/^$1/i;
         } elsif (/\S/) {
            print "blockref: unparsable line: $_\n";
         }
      }
   } else {
      print "no blockref\n";
   }
}

read_blockuri;
read_blockref;

use Tie::Cache;
tie %whois_cache, Tie::Cache::, $MAX_CONNECTS * 1.5;

sub conn::err_block_country {
   my $self = shift;
   my $whois = shift;

   $whois =~ s/&/&amp;/g;
   $whois =~ s/</&lt;/g;
   $self->err(403, "forbidden", { "Content-Type" => "text/html", Connection => "close" }, <<EOF);
<html>
<head>
<title>This material is licensed in your country!</title>
</head>
<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">

<h1>This material is licensed in your country!</h1>

<p>My research has shown that your IP address
(<b>$self->{remote_addr}</b>) most probably is located in this country:
<b>$self->{country}</b> (ISO-3166-2 code, XX == unknown). The full record is:</p>

<pre>
$whois
</pre>

<p>My database says that the material you are trying to access is licensed
in your country. If I would distribute these files to your country I would
actively <em>hurt</em> the industry behind it, which includes the artists
and authors of these videos/mangas. So I hope you understand that I try to
avoid this.</p>

<p>Please see the <a href="http://www.goof.com/pcg/marc/animefaq.html#licensed">FAQ</a>
for a more thorough explanation.</p>

<p>If you <em>really</em> think that this is wrong, i.e. the
material you tried to access is <em>not</em> licensed in your
country or your ip address was misdetected, you can write to <a
href="mailto:licensed\@plan9.de">licensed\@plan9.de</a>. Please explain
what happened and why you think this is wrong in as much detail as
possible.</p>

<div align="right">Thanks a lot for understanding.</div>

</body>
</html>
EOF
}

sub conn::err_block_referer {
   my $self = shift;

   my $uri = $self->{uri};
   $uri =~ s/\/[^\/]+$/\//;

   $self->slog(6, "REFERER($self->{uri},$self->{h}{referer})");

   $whois =~ s/&/&amp;/g;
   $whois =~ s/</&lt;/g;
   $self->err(203, "non-authoritative", { "Content-Type" => "text/html" }, <<EOF);
<html>
<head>
<title>Unallowed Referral</title>
</head>
<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">

<h1>The site which referred you has done something bad!</h1>

<p>It seems that you are coming from this URL:</p>

<pre>$self->{h}{referer}</pre>

<p>This site has been blocked, either because it required you to pay
money, forced you to click on banners, claimed these files were theirs
or something very similar. Please note that you can download these files
<em>without</em> having to pay, <em>without</em> clicking banners or jump
through other hoops.</p>

<p><b>Sites like the one you came from actively hurt the distribution of
these files and the service quality for you since I can't move or correct
files and you will likely not be able to see the full archive.</b></p>

<p>Having that this, you can find the original content (if it is still
there) by <b>following <a href="$uri">this link</a>.</b></p>

<div align="right">Thanks a lot for understanding.</div>

</body>
</html>
EOF
}

sub conn::access_check {
   my $self = shift;

   my $ref = $self->{h}{referer};
   my $uri = $self->{path};
   my %disallow;

   for (@blockref) {
      $self->err_block_referer if $ref =~ $_;
   }

   for (@blockuri) {
      if ($uri =~ $_->[0]) {
         $disallow{$_}++ for @{$_->[1]};
      }
   }
   
   my $whois = $whois_cache{$self->{remote_addr}}
               ||= ::ip_request($self->{remote_addr});

   my $country = "XX";

   if ($whois =~ /^\*cy: (\S+)/m) {
      $country = uc $1;
   } else {
      $self->slog(9, "no country($whois)");
   }

   $self->{country} = $country;

   if ($disallow{$country}) {
      $self->err_block_country($whois);
   }
}

1;
Revision:	1.7
Committed:	Mon Aug 20 16:58:19 2001 UTC (22 years, 10 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.6:	+4 -3 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1
2	root	1.6	our @blockuri;
3			our @blockref;
4	root	1.1
5	root	1.6	sub read_blockuri {
6	root	1.1	local *B;
7			my %group;
8	root	1.6	@blockuri = ();
9			if (open B, "<blockuri") {
10	root	1.1	while (<B>) {
11			chomp;
12			if (/^group\s+(\S+)\s+(.*)/i) {
13			$group{$1} = [split /\s+/, $2];
14			} elsif (/^!([^\t])\t\s(.*)/) {
15			my $g = $1;
16			my @r;
17			for (split /\s+/, $2) {
18			push @r, $group{$_} ? @{$group{$_}} : $_;
19			}
20			print "not($g) => (@r)\n";
21	root	1.6	push @blockuri, [qr/$g/i, \@r];
22	root	1.1	} elsif (/\S/) {
23	root	1.6	print "blockuri: unparsable line: $_\n";
24	root	1.1	}
25			}
26			} else {
27	root	1.6	print "no blockuri\n";
28	root	1.1	}
29			}
30
31	root	1.6	sub read_blockref {
32			local *B;
33			@blockref = ();
34			if (open B, "<blockreferer") {
35			while (<B>) {
36			chomp;
37			if (/^([^\t])\t\s(.*)/) {
38			push @blockref, qr/^$1/i;
39			} elsif (/\S/) {
40			print "blockref: unparsable line: $_\n";
41			}
42			}
43			} else {
44			print "no blockref\n";
45			}
46			}
47
48			read_blockuri;
49			read_blockref;
50	root	1.1
51	root	1.5	use Tie::Cache;
52			tie %whois_cache, Tie::Cache::, $MAX_CONNECTS * 1.5;
53
54	root	1.6	sub conn::err_block_country {
55	root	1.1	my $self = shift;
56	root	1.6	my $whois = shift;
57	root	1.1
58	root	1.6	$whois =~ s/&/&/g;
59			$whois =~ s/</</g;
60	root	1.7	$self->err(403, "forbidden", { "Content-Type" => "text/html", Connection => "close" }, <<EOF);
61	root	1.1	<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	root	1.6	<b>$self->{country}</b> (ISO-3166-2 code, XX == unknown). The full record is:</p>
72	root	1.1
73			<pre>
74			$whois
75			</pre>
76
77			<p>My database says that the material you are trying to access is licensed
78			in your country. If I would distribute these files to your country I would
79			actively <em>hurt</em> the industry behind it, which includes the artists
80			and authors of these videos/mangas. So I hope you understand that I try to
81			avoid this.</p>
82
83	root	1.7	<p>Please see the <a href="http://www.goof.com/pcg/marc/animefaq.html#licensed">FAQ</a>
84			for a more thorough explanation.</p>
85
86	root	1.1	<p>If you <em>really</em> think that this is wrong, i.e. the
87			material you tried to access is <em>not</em> licensed in your
88			country or your ip address was misdetected, you can write to <a
89			href="mailto:licensed\@plan9.de">licensed\@plan9.de</a>. Please explain
90			what happened and why you think this is wrong in as much detail as
91			possible.</p>
92
93			<div align="right">Thanks a lot for understanding.</div>
94
95			</body>
96			</html>
97			EOF
98	root	1.6	}
99
100			sub 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/&/&/g;
109			$whois =~ s/</</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
124			money, forced you to click on banners, claimed these files were theirs
125			or 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
127			through other hoops.</p>
128
129			<p><b>Sites like the one you came from actively hurt the distribution of
130			these files and the service quality for you since I can't move or correct
131			files 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
134			there) 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>
140			EOF
141			}
142
143			sub conn::access_check {
144			my $self = shift;
145
146			my $ref = $self->{h}{referer};
147			my $uri = $self->{path};
148			my %disallow;
149
150			for (@blockref) {
151			$self->err_block_referer if $ref =~ $_;
152			}
153
154			for (@blockuri) {
155			if ($uri =~ $_->[0]) {
156			$disallow{$_}++ for @{$_->[1]};
157			}
158			}
159
160			my $whois = $whois_cache{$self->{remote_addr}}
161			\|\|= ::ip_request($self->{remote_addr});
162
163			my $country = "XX";
164
165			if ($whois =~ /^\*cy: (\S+)/m) {
166			$country = uc $1;
167			} else {
168			$self->slog(9, "no country($whois)");
169			}
170
171			$self->{country} = $country;
172
173			if ($disallow{$country}) {
174			$self->err_block_country($whois);
175	root	1.1	}
176			}
177
178			1;