3 # Redirector for hires.video.debconf.org; redirects the viewer to the
4 # closest reflector geographically/network-wise.
5 # Based on the http.debian.net code; heavily modified for the needs of the
9 # Copyright (C) 2011, 2012 by Raphael Geissert <geissert@debian.org>
10 # Copyright (C) 2013 by Steinar H. Gunderson <sesse@debian.org>
12 # This file is free software: you can redistribute it and/or modify
13 # it under the terms of the GNU General Public License as published by
14 # the Free Software Foundation, either version 3 of the License, or
15 # (at your option) any later version.
17 # This file is distributed in the hope that it will be useful,
18 # but WITHOUT ANY WARRANTY; without even the implied warranty of
19 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 # GNU General Public License for more details.
22 # You should have received a copy of the GNU General Public License
23 # along with this file If not, see <http://www.gnu.org/licenses/>.
25 # On Debian systems, the complete text of the GNU General
26 # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'.
37 '81.7.11.163', # pkern (DE)
42 '2400:8900::f03c:91ff:feae:fac8',
43 '2a01:4f8:131:1528:deb::23',
44 '2a02:180:1:1::517:ba3', # pkern (DE)
47 @ipv4_mirrors, @ipv6_mirrors
50 # Usage: redir.pl?url=/foo1.ts
51 # Test (make sure -debug1 is set below):
53 # REMOTE_ADDR=1.2.3.4 ./redir.pl
54 use CGI::Simple qw(-debug1);
55 $CGI::Simple::POST_MAX = 0;
56 $CGI::Simple::DISABLE_UPLOADS = 1;
57 my $q = new CGI::Simple;
59 my $request_method = $q->request_method() || 'HEAD';
60 # abort POST and other requests ASAP
61 if ($request_method ne 'GET' && $request_method ne 'HEAD') {
62 print "Status: 405 Not Allowed\r\n";
63 print "Allow: GET, HEAD\r\n\r\n";
72 our $metric = ''; # alt: taxicab (default) | euclidean
73 our $xtra_headers = 1;
76 my %nearby_continents = (
77 'AF' => [ qw(EU NA AS SA OC) ],
78 'SA' => [ qw(NA EU OC AS AF) ],
79 'OC' => [ qw(NA AS EU SA AF) ],
80 'AS' => [ qw(EU NA OC SA AF) ],
81 'NA' => [ qw(EU AS OC SA AF) ],
82 'EU' => [ qw(NA AS SA OC AF) ],
85 my %nearby_country = (
86 'NA' => [ qw(US CA) ],
91 sub consider_mirror($);
92 sub url_for_mirror($);
98 unless ($request_method eq 'HEAD') {
101 print "Vary: x-web-demo\r\n";
104 $action = 'demo' if (exists($ENV{'HTTP_X_WEB_DEMO'}));
107 my $IP = $ENV{'HTTP_X_FORWARDED_FOR'};
109 $IP = $q->remote_addr;
112 print STDERR "IP: $IP\n";
113 #$IP = `wget -O- -q http://myip.dnsomatic.com/` if ($IP eq '127.0.0.1');
116 my $url = clean_url($q->param('url') || '');
118 my $client_geoloc = geolocate($IP);
119 print_xtra('IP', $client_geoloc->{ip});
120 print_xtra('AS', $client_geoloc->{as});
121 print_xtra('URL', $url);
122 print_xtra('Country', $client_geoloc->{country});
123 print_xtra('Continent', $client_geoloc->{continent});
125 # Geolocate all the mirrors
126 our $server_geoloc = {};
127 for my $mirror (@all_mirrors, '80.83.52.180') {
128 $server_geoloc->{$mirror} = geolocate($mirror);
133 @mirrors = @ipv6_mirrors;
135 @mirrors = @ipv4_mirrors;
141 # special override for debconf ranges (ick)
142 if ($IP =~ /^83\.68\.21[6789]\./ || $IP =~ /^80\.83\.(48|49|50|51)\./) {
143 $match_type = 'Debconf-override';
144 consider_mirror('80.83.52.180');
145 } elsif ($IP =~ /^2001:41b8:203:/) {
146 $match_type = 'Debconf-override-v6-to-v4';
147 consider_mirror('80.83.52.180'); # no internal IPv6 address
152 for my $mirror (@mirrors) {
153 next unless ($server_geoloc->{$mirror}{as} eq $client_geoloc->{as});
154 next unless ($server_geoloc->{$mirror}{continent} eq $client_geoloc->{continent});
157 consider_mirror($mirror);
162 # if (!$match_type && $as && $peers_db_store && !$ipv6 && -f $peers_db_store) {
163 # my $peers_db = retrieve($peers_db_store);
165 # foreach my $match (keys %{$peers_db->{$as}}) {
166 # next unless (exists($db->{'all'}{$match}{$mirror_type.'-http'}));
167 # next unless (mirror_is_in_continent($rdb, $match, $continent));
169 # $match_type = 'AS-peer' if (consider_mirror ($match));
175 for my $mirror (@mirrors) {
176 next unless ($server_geoloc->{$mirror}{country} eq $client_geoloc->{country});
177 $match_type = 'country';
178 consider_mirror($mirror);
182 # match by nearby-country
183 my $continent = $client_geoloc->{continent};
184 if (!$match_type && exists($nearby_country{$continent})) {
185 for my $country (@{$nearby_country{$continent}}) {
186 for my $mirror (@mirrors) {
187 next unless ($server_geoloc->{$mirror}{country} eq $country);
188 $match_type = 'nearby-country';
189 consider_mirror($mirror);
196 my @continents = ($continent, @{$nearby_continents{$continent}});
198 for my $mirror_continent (@continents) {
199 last if ($match_type);
202 if ($mirror_continent eq $continent) {
203 $mtype = 'continent';
205 $mtype = 'nearby-continent';
208 for my $mirror (@mirrors) {
209 next unless ($server_geoloc->{$mirror}{continent} eq $mirror_continent);
210 $match_type = $mtype;
211 consider_mirror($mirror);
216 # something went awry, we don't know how to handle this user, we failed
218 print "Status: 503 Service Unavailable\r\n\r\n";
223 my @sorted_hosts = sort { $hosts{$a} <=> $hosts{$b} } keys %hosts;
227 my @iq_dists = map { $hosts{$_} } Mirror::Math::iquartile(@sorted_hosts);
228 $dev = Mirror::Math::stddev(@iq_dists);
230 # Closest host (or one of many), to use as the base distance
231 my $host = $sorted_hosts[0];
233 print_xtra('Std-Dev', $dev);
234 print_xtra('Population', scalar(@sorted_hosts));
235 print_xtra('Closest-Distance', $hosts{$host});
237 for my $h (@sorted_hosts) {
238 # NOTE: this might need some additional work, as we should probably
239 # guarantee a certain amount of alt hosts to choose from
240 if (($hosts{$h} - $hosts{$host}) <= $dev &&
241 (scalar(@close_hosts) < 4 || $hosts{$h} == $hosts{$close_hosts[-1]})) {
242 push @close_hosts, $h;
244 # the list is sorted, if we didn't accept this one won't accept
251 my $n = int(rand scalar(@close_hosts));
252 $host = $close_hosts[$n];
254 print_xtra('Distance', $hosts{$host});
255 print_xtra('Match-Type', $match_type);
257 if ($action eq 'redir') {
258 print "Content-type: text/plain\r\n";
259 print "Status: 302 Moved Temporarily\r\n";
262 if ($host eq '2001:67c:29f4::50' || $host eq '193.35.52.50') {
266 print "Location: http://[".$host."]:$port/".$url."\r\n";
268 print "Location: http://".$host.":$port/".$url."\r\n";
270 } elsif ($action eq 'demo') {
271 print "Status: 200 OK\r\n";
272 print "Cache-control: no-cache\r\n";
273 print "Pragma: no-cache\r\n";
274 } elsif ($action eq 'list') {
275 print "Content-type: text/plain\r\n";
276 print "Status: 200 OK\r\n";
277 for my $host (@close_hosts) {
278 push @output, url_for_mirror($host)."\n";
281 die("FIXME: unknown action '$action'");
286 for my $line (@output) {
293 print "X-$_[0]: $_[1]\r\n"
301 $url =~ s,^\.\.?/,,g;
302 $url =~ s,(?<=/)\.\.?(?:/|$),,g;
303 $url = CGI::Simple->url_encode($url);
308 sub consider_mirror($) {
311 my $geoloc = $server_geoloc->{$ip};
313 my $pihalf = Math::Trig::pi / 2;
314 my $lon1 = Math::Trig::deg2rad($geoloc->{'lon'});
315 my $lat1 = $pihalf - Math::Trig::deg2rad($geoloc->{'lat'});
316 my $lon2 = Math::Trig::deg2rad($client_geoloc->{'lon'});
317 my $lat2 = $pihalf - Math::Trig::deg2rad($client_geoloc->{'lat'});
319 $hosts{$ip} = Math::Trig::great_circle_distance($lon1, $lat1, $lon2, $lat2);
325 our $ipv6 = ($IP =~ m/:/);
327 # Handle IPv6 over IPv4 requests as if they originated from an IPv4
328 if ($ipv6 && $IP =~ m/^200(2|1(?=:0:)):/) {
329 my $tunnel_type = $1;
331 print_xtra('IPv6', $IP);
333 if ($tunnel_type == 1) { # teredo
334 $IP =~ m/:(\w{0,2}?)(\w{1,2}):(\w{0,2}?)(\w{1,2})$/ or die;
335 $IP = join('.', hex($1)^0xff, hex($2)^0xff, hex($3)^0xff, hex($4)^0xff);
336 } elsif ($tunnel_type == 2) { # 6to4
337 $IP =~ m/^2002:(\w{0,2}?)(\w{1,2}):(\w{0,2}?)(\w{1,2}):/ or die;
338 $IP = join('.', hex($1), hex($2), hex($3), hex($4));
347 $g_city = Geo::IP->open('geoip/GeoLiteCity.dat', GEOIP_MMAP_CACHE);
348 $g_as = Geo::IP->open('geoip/GeoIPASNum.dat', GEOIP_MMAP_CACHE);
350 $geo_rec = $g_city->record_by_addr($IP);
351 ($as) = split /\s+/, ($g_as->org_by_addr($IP) || ' ');
353 $g_city = Geo::IP->open('geoip/GeoLiteCityv6.dat', GEOIP_MMAP_CACHE);
354 $g_as = Geo::IP->open('geoip/GeoIPASNumv6.dat', GEOIP_MMAP_CACHE);
356 $geo_rec = $g_city->record_by_addr_v6($IP);
357 ($as) = split /\s+/, ($g_as->org_by_addr_v6($IP) || ' ');
360 if (!defined($geo_rec)) {
371 $as = Mirror::AS::convert($as);
373 $lat = $geo_rec->latitude;
374 $lon = $geo_rec->longitude;
376 my $continent = $geo_rec->continent_code;
377 $continent = 'EU' if ($continent eq '--');
382 country => $geo_rec->country_code,
383 continent => $continent,