--- /dev/null
+#!/usr/bin/perl -w
+
+# Redirector for hires.video.debconf.org; redirects the viewer to the
+# closest reflector geographically/network-wise.
+# Based on the http.debian.net code; heavily modified for the needs of the
+# Debconf redirector.
+
+####################
+# Copyright (C) 2011, 2012 by Raphael Geissert <geissert@debian.org>
+# Copyright (C) 2013 by Steinar H. Gunderson <sesse@debian.org>
+#
+# This file is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This file is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this file If not, see <http://www.gnu.org/licenses/>.
+#
+# On Debian systems, the complete text of the GNU General
+# Public License 3 can be found in '/usr/share/common-licenses/GPL-3'.
+####################
+
+use strict;
+use warnings;
+use lib '.';
+
+my @ipv4_mirrors = (
+ '117.121.243.49',
+ '193.35.52.50',
+ '46.4.205.40',
+ '81.7.11.163', # pkern (DE)
+ '106.187.92.155',
+);
+my @ipv6_mirrors = (
+ '2001:67c:29f4::50',
+ '2400:8900::f03c:91ff:feae:fac8',
+ '2a01:4f8:131:1528:deb::23',
+ '2a02:180:1:1::517:ba3', # pkern (DE)
+);
+my @all_mirrors = (
+ @ipv4_mirrors, @ipv6_mirrors
+);
+
+# Usage: redir.pl?url=/foo1.ts
+# Test (make sure -debug1 is set below):
+# ./redir.pl
+# REMOTE_ADDR=1.2.3.4 ./redir.pl
+use CGI::Simple qw(-debug1);
+$CGI::Simple::POST_MAX = 0;
+$CGI::Simple::DISABLE_UPLOADS = 1;
+my $q = new CGI::Simple;
+
+my $request_method = $q->request_method() || 'HEAD';
+# abort POST and other requests ASAP
+if ($request_method ne 'GET' && $request_method ne 'HEAD') {
+ print "Status: 405 Not Allowed\r\n";
+ print "Allow: GET, HEAD\r\n\r\n";
+ exit;
+}
+
+use Geo::IP;
+use Math::Trig;
+use Mirror::Math;
+use Mirror::AS;
+
+our $metric = ''; # alt: taxicab (default) | euclidean
+our $xtra_headers = 1;
+my $random_sort = 1;
+
+my %nearby_continents = (
+ 'AF' => [ qw(EU NA AS SA OC) ],
+ 'SA' => [ qw(NA EU OC AS AF) ],
+ 'OC' => [ qw(NA AS EU SA AF) ],
+ 'AS' => [ qw(EU NA OC SA AF) ],
+ 'NA' => [ qw(EU AS OC SA AF) ],
+ 'EU' => [ qw(NA AS SA OC AF) ],
+);
+
+my %nearby_country = (
+ 'NA' => [ qw(US CA) ],
+);
+
+sub print_xtra($$);
+sub clean_url($);
+sub consider_mirror($);
+sub url_for_mirror($);
+sub geolocate($);
+
+my @output;
+my $action = 'redir';
+
+unless ($request_method eq 'HEAD') {
+ $xtra_headers = 0;
+} else {
+ print "Vary: x-web-demo\r\n";
+}
+
+$action = 'demo' if (exists($ENV{'HTTP_X_WEB_DEMO'}));
+
+####
+my $IP = $ENV{'HTTP_X_FORWARDED_FOR'};
+if (!defined($IP)) {
+ $IP = $q->remote_addr;
+}
+$IP =~ s/,.*//;
+print STDERR "IP: $IP\n";
+#$IP = `wget -O- -q http://myip.dnsomatic.com/` if ($IP eq '127.0.0.1');
+####
+
+my $url = clean_url($q->param('url') || '');
+
+my $client_geoloc = geolocate($IP);
+print_xtra('IP', $client_geoloc->{ip});
+print_xtra('AS', $client_geoloc->{as});
+print_xtra('URL', $url);
+print_xtra('Country', $client_geoloc->{country});
+print_xtra('Continent', $client_geoloc->{continent});
+
+# Geolocate all the mirrors
+our $server_geoloc = {};
+for my $mirror (@all_mirrors, '80.83.52.180') {
+ $server_geoloc->{$mirror} = geolocate($mirror);
+}
+
+my @mirrors;
+if ($IP =~ /:/) {
+ @mirrors = @ipv6_mirrors;
+} else {
+ @mirrors = @ipv4_mirrors;
+}
+
+our %hosts;
+my $match_type = '';
+
+# special override for debconf ranges (ick)
+if ($IP =~ /^83\.68\.21[6789]\./ || $IP =~ /^80\.83\.(48|49|50|51)\./) {
+ $match_type = 'Debconf-override';
+ consider_mirror('80.83.52.180');
+} elsif ($IP =~ /^2001:41b8:203:/) {
+ $match_type = 'Debconf-override-v6-to-v4';
+ consider_mirror('80.83.52.180'); # no internal IPv6 address
+}
+
+# match by AS
+if (!$match_type) {
+ for my $mirror (@mirrors) {
+ next unless ($server_geoloc->{$mirror}{as} eq $client_geoloc->{as});
+ next unless ($server_geoloc->{$mirror}{continent} eq $client_geoloc->{continent});
+
+ $match_type = 'AS';
+ consider_mirror($mirror);
+ }
+}
+
+# match by AS peer
+# if (!$match_type && $as && $peers_db_store && !$ipv6 && -f $peers_db_store) {
+# my $peers_db = retrieve($peers_db_store);
+#
+# foreach my $match (keys %{$peers_db->{$as}}) {
+# next unless (exists($db->{'all'}{$match}{$mirror_type.'-http'}));
+# next unless (mirror_is_in_continent($rdb, $match, $continent));
+#
+# $match_type = 'AS-peer' if (consider_mirror ($match));
+# }
+# }
+
+# match by country
+if (!$match_type) {
+ for my $mirror (@mirrors) {
+ next unless ($server_geoloc->{$mirror}{country} eq $client_geoloc->{country});
+ $match_type = 'country';
+ consider_mirror($mirror);
+ }
+}
+
+# match by nearby-country
+my $continent = $client_geoloc->{continent};
+if (!$match_type && exists($nearby_country{$continent})) {
+ for my $country (@{$nearby_country{$continent}}) {
+ for my $mirror (@mirrors) {
+ next unless ($server_geoloc->{$mirror}{country} eq $country);
+ $match_type = 'nearby-country';
+ consider_mirror($mirror);
+ }
+ }
+}
+
+# match by continent
+if (!$match_type) {
+ my @continents = ($continent, @{$nearby_continents{$continent}});
+
+ for my $mirror_continent (@continents) {
+ last if ($match_type);
+
+ my $mtype;
+ if ($mirror_continent eq $continent) {
+ $mtype = 'continent';
+ } else {
+ $mtype = 'nearby-continent';
+ }
+
+ for my $mirror (@mirrors) {
+ next unless ($server_geoloc->{$mirror}{continent} eq $mirror_continent);
+ $match_type = $mtype;
+ consider_mirror($mirror);
+ }
+ }
+}
+
+# something went awry, we don't know how to handle this user, we failed
+if (!$match_type) {
+ print "Status: 503 Service Unavailable\r\n\r\n";
+ exit;
+}
+
+
+my @sorted_hosts = sort { $hosts{$a} <=> $hosts{$b} } keys %hosts;
+my @close_hosts;
+my $dev;
+
+my @iq_dists = map { $hosts{$_} } Mirror::Math::iquartile(@sorted_hosts);
+$dev = Mirror::Math::stddev(@iq_dists);
+
+# Closest host (or one of many), to use as the base distance
+my $host = $sorted_hosts[0];
+
+print_xtra('Std-Dev', $dev);
+print_xtra('Population', scalar(@sorted_hosts));
+print_xtra('Closest-Distance', $hosts{$host});
+
+for my $h (@sorted_hosts) {
+ # NOTE: this might need some additional work, as we should probably
+ # guarantee a certain amount of alt hosts to choose from
+ if (($hosts{$h} - $hosts{$host}) <= $dev &&
+ (scalar(@close_hosts) < 4 || $hosts{$h} == $hosts{$close_hosts[-1]})) {
+ push @close_hosts, $h;
+ } else {
+ # the list is sorted, if we didn't accept this one won't accept
+ # the next
+ last;
+ }
+}
+
+if ($random_sort) {
+ my $n = int(rand scalar(@close_hosts));
+ $host = $close_hosts[$n];
+}
+print_xtra('Distance', $hosts{$host});
+print_xtra('Match-Type', $match_type);
+
+if ($action eq 'redir') {
+ print "Content-type: text/plain\r\n";
+ print "Status: 302 Moved Temporarily\r\n";
+
+ my $port = 9094;
+ if ($host eq '2001:67c:29f4::50' || $host eq '193.35.52.50') {
+ $port = 9095;
+ }
+ if ($host =~ /:/) {
+ print "Location: http://[".$host."]:$port/".$url."\r\n";
+ } else {
+ print "Location: http://".$host.":$port/".$url."\r\n";
+ }
+} elsif ($action eq 'demo') {
+ print "Status: 200 OK\r\n";
+ print "Cache-control: no-cache\r\n";
+ print "Pragma: no-cache\r\n";
+} elsif ($action eq 'list') {
+ print "Content-type: text/plain\r\n";
+ print "Status: 200 OK\r\n";
+ for my $host (@close_hosts) {
+ push @output, url_for_mirror($host)."\n";
+ }
+} else {
+ die("FIXME: unknown action '$action'");
+}
+
+print "\r\n";
+
+for my $line (@output) {
+ print $line;
+}
+
+exit;
+
+sub print_xtra($$) {
+ print "X-$_[0]: $_[1]\r\n"
+ if ($xtra_headers);
+}
+
+sub clean_url($) {
+ my $url = shift;
+ $url =~ s,//,/,g;
+ $url =~ s,^/,,;
+ $url =~ s,^\.\.?/,,g;
+ $url =~ s,(?<=/)\.\.?(?:/|$),,g;
+ $url = CGI::Simple->url_encode($url);
+ $url =~ s,%2F,/,g;
+ return $url;
+}
+
+sub consider_mirror($) {
+ my ($ip) = @_;
+
+ my $geoloc = $server_geoloc->{$ip};
+
+ my $pihalf = Math::Trig::pi / 2;
+ my $lon1 = Math::Trig::deg2rad($geoloc->{'lon'});
+ my $lat1 = $pihalf - Math::Trig::deg2rad($geoloc->{'lat'});
+ my $lon2 = Math::Trig::deg2rad($client_geoloc->{'lon'});
+ my $lat2 = $pihalf - Math::Trig::deg2rad($client_geoloc->{'lat'});
+
+ $hosts{$ip} = Math::Trig::great_circle_distance($lon1, $lat1, $lon2, $lat2);
+}
+
+sub geolocate($) {
+ my ($IP) = @_;
+
+ our $ipv6 = ($IP =~ m/:/);
+
+ # Handle IPv6 over IPv4 requests as if they originated from an IPv4
+ if ($ipv6 && $IP =~ m/^200(2|1(?=:0:)):/) {
+ my $tunnel_type = $1;
+ $ipv6 = 0;
+ print_xtra('IPv6', $IP);
+
+ if ($tunnel_type == 1) { # teredo
+ $IP =~ m/:(\w{0,2}?)(\w{1,2}):(\w{0,2}?)(\w{1,2})$/ or die;
+ $IP = join('.', hex($1)^0xff, hex($2)^0xff, hex($3)^0xff, hex($4)^0xff);
+ } elsif ($tunnel_type == 2) { # 6to4
+ $IP =~ m/^2002:(\w{0,2}?)(\w{1,2}):(\w{0,2}?)(\w{1,2}):/ or die;
+ $IP = join('.', hex($1), hex($2), hex($3), hex($4));
+ }
+ }
+
+ my ($g_city, $g_as);
+ my ($geo_rec, $as);
+ our ($lat, $lon);
+
+ if (!$ipv6) {
+ $g_city = Geo::IP->open('geoip/GeoLiteCity.dat', GEOIP_MMAP_CACHE);
+ $g_as = Geo::IP->open('geoip/GeoIPASNum.dat', GEOIP_MMAP_CACHE);
+
+ $geo_rec = $g_city->record_by_addr($IP);
+ ($as) = split /\s+/, ($g_as->org_by_addr($IP) || ' ');
+ } else {
+ $g_city = Geo::IP->open('geoip/GeoLiteCityv6.dat', GEOIP_MMAP_CACHE);
+ $g_as = Geo::IP->open('geoip/GeoIPASNumv6.dat', GEOIP_MMAP_CACHE);
+
+ $geo_rec = $g_city->record_by_addr_v6($IP);
+ ($as) = split /\s+/, ($g_as->org_by_addr_v6($IP) || ' ');
+ }
+
+ if (!defined($geo_rec)) {
+ return {
+ ip => $IP,
+ as => 0,
+ country => '--',
+ continent => 'EU',
+ lon => 0.0,
+ lat => 0.0,
+ };
+ }
+
+ $as = Mirror::AS::convert($as);
+
+ $lat = $geo_rec->latitude;
+ $lon = $geo_rec->longitude;
+
+ my $continent = $geo_rec->continent_code;
+ $continent = 'EU' if ($continent eq '--');
+
+ return {
+ ip => $IP,
+ as => $as,
+ country => $geo_rec->country_code,
+ continent => $continent,
+ lon => $lon,
+ lat => $lat,
+ };
+}
projects / videoredirector / commitdiff