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" }, <<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>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/\/[^\/]+$/\//;
   $uri = escape_uri $uri;
   print "hiho $uri\n";#d#

   $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.6
Committed:	Sun Aug 19 23:57:52 2001 UTC (22 years, 10 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.5:	+112 -38 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			$self->err(403, "forbidden", { "Content-Type" => "text/html" }, <<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			<p>If you <em>really</em> think that this is wrong, i.e. the
84			material you tried to access is <em>not</em> licensed in your
85			country or your ip address was misdetected, you can write to <a
86			href="mailto:licensed\@plan9.de">licensed\@plan9.de</a>. Please explain
87			what happened and why you think this is wrong in as much detail as
88			possible.</p>
89
90			<div align="right">Thanks a lot for understanding.</div>
91
92			</body>
93			</html>
94			EOF
95	root	1.6	}
96
97			sub conn::err_block_referer {
98			my $self = shift;
99
100			my $uri = $self->{uri};
101			$uri =~ s/\/[^\/]+$/\//;
102			$uri = escape_uri $uri;
103			print "hiho $uri\n";#d#
104
105			$self->slog(6, "REFERER($self->{uri},$self->{h}{referer})");
106
107			$whois =~ s/&/&/g;
108			$whois =~ s/</</g;
109			$self->err(203, "non-authoritative", { "Content-Type" => "text/html" }, <<EOF);
110			<html>
111			<head>
112			<title>Unallowed Referral</title>
113			</head>
114			<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
115
116			<h1>The site which referred you has done something bad!</h1>
117
118			<p>It seems that you are coming from this URL:</p>
119
120			<pre>$self->{h}{referer}</pre>
121
122			<p>This site has been blocked, either because it required you to pay
123			money, forced you to click on banners, claimed these files were theirs
124			or something very similar. Please note that you can download these files
125			<em>without</em> having to pay, <em>without</em> clicking banners or jump
126			through other hoops.</p>
127
128			<p><b>Sites like the one you came from actively hurt the distribution of
129			these files and the service quality for you since I can't move or correct
130			files and you will likely not be able to see the full archive.</b></p>
131
132			<p>Having that this, you can find the original content (if it is still
133			there) by <b>following <a href="$uri">this link</a>.</b></p>
134
135			<div align="right">Thanks a lot for understanding.</div>
136
137			</body>
138			</html>
139			EOF
140			}
141
142			sub conn::access_check {
143			my $self = shift;
144
145			my $ref = $self->{h}{referer};
146			my $uri = $self->{path};
147			my %disallow;
148
149			for (@blockref) {
150			$self->err_block_referer if $ref =~ $_;
151			}
152
153			for (@blockuri) {
154			if ($uri =~ $_->[0]) {
155			$disallow{$_}++ for @{$_->[1]};
156			}
157			}
158
159			my $whois = $whois_cache{$self->{remote_addr}}
160			\|\|= ::ip_request($self->{remote_addr});
161
162			my $country = "XX";
163
164			if ($whois =~ /^\*cy: (\S+)/m) {
165			$country = uc $1;
166			} else {
167			$self->slog(9, "no country($whois)");
168			}
169
170			$self->{country} = $country;
171
172			if ($disallow{$country}) {
173			$self->err_block_country($whois);
174	root	1.1	}
175			}
176
177			1;