git.sesse.net Git - videoredirector/blob - redir.pl

   1 #!/usr/bin/perl -w
   2
   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
   6 #    Debconf redirector.
   7
   8 ####################
   9 #    Copyright (C) 2011, 2012 by Raphael Geissert <geissert@debian.org>
  10 #    Copyright (C) 2013 by Steinar H. Gunderson <sesse@debian.org>
  11 #
  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.
  16 #
  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.
  21 #
  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/>.
  24 #
  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'.
  27 ####################
  28
  29 use strict;
  30 use warnings;
  31 use lib '.';
  32
  33 my @ipv4_mirrors = (
  34     '117.121.243.49',
  35     '193.35.52.50',
  36     '46.4.205.40',
  37     '81.7.11.163',   # pkern (DE)
  38     '106.187.92.155',
  39 );
  40 my @ipv6_mirrors = (
  41     '2001:67c:29f4::50',
  42     '2400:8900::f03c:91ff:feae:fac8',
  43     '2a01:4f8:131:1528:deb::23',
  44     '2a02:180:1:1::517:ba3',  # pkern (DE)
  45 );
  46 my @all_mirrors = (
  47     @ipv4_mirrors, @ipv6_mirrors
  48 );
  49
  50 # Usage: redir.pl?url=/foo1.ts
  51 # Test (make sure -debug1 is set below):
  52 #   ./redir.pl
  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;
  58
  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";
  64     exit;
  65 }
  66
  67 use Geo::IP;
  68 use Math::Trig;
  69 use Mirror::Math;
  70 use Mirror::AS;
  71
  72 our $metric = ''; # alt: taxicab (default) | euclidean
  73 our $xtra_headers = 1;
  74 my $random_sort = 1;
  75
  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) ],
  83 );
  84
  85 my %nearby_country = (
  86     'NA' => [ qw(US CA) ],
  87 );
  88
  89 sub print_xtra($$);
  90 sub clean_url($);
  91 sub consider_mirror($);
  92 sub url_for_mirror($);
  93 sub geolocate($);
  94
  95 my @output;
  96 my $action = 'redir';
  97
  98 unless ($request_method eq 'HEAD') {
  99     $xtra_headers = 0;
 100 } else {
 101     print "Vary: x-web-demo\r\n";
 102 }
 103
 104 $action = 'demo' if (exists($ENV{'HTTP_X_WEB_DEMO'}));
 105
 106 ####
 107 my $IP = $ENV{'HTTP_X_FORWARDED_FOR'};
 108 if (!defined($IP)) {
 109     $IP = $q->remote_addr;
 110 }
 111 $IP =~ s/,.*//;
 112 print STDERR "IP: $IP\n";
 113 #$IP = `wget -O- -q http://myip.dnsomatic.com/` if ($IP eq '127.0.0.1');
 114 ####
 115
 116 my $url = clean_url($q->param('url') || '');
 117
 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});
 124
 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);
 129 }
 130
 131 my @mirrors;
 132 if ($IP =~ /:/) {
 133     @mirrors = @ipv6_mirrors;
 134 } else {
 135     @mirrors = @ipv4_mirrors;
 136 }
 137
 138 our %hosts;
 139 my $match_type = '';
 140
 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
 148 }
 149
 150 # match by AS
 151 if (!$match_type) {
 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});
 155
 156         $match_type = 'AS';
 157         consider_mirror($mirror);
 158     }
 159 }
 160
 161 # match by AS peer
 162 # if (!$match_type && $as && $peers_db_store && !$ipv6 && -f $peers_db_store) {
 163 #     my $peers_db = retrieve($peers_db_store);
 164 #
 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));
 168 #
 169 #       $match_type = 'AS-peer' if (consider_mirror ($match));
 170 #     }
 171 # }
 172
 173 # match by country
 174 if (!$match_type) {
 175     for my $mirror (@mirrors) {
 176         next unless ($server_geoloc->{$mirror}{country} eq $client_geoloc->{country});
 177         $match_type = 'country';
 178         consider_mirror($mirror);
 179     }
 180 }
 181
 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);
 190         }
 191     }
 192 }
 193
 194 # match by continent
 195 if (!$match_type) {
 196     my @continents = ($continent, @{$nearby_continents{$continent}});
 197
 198     for my $mirror_continent (@continents) {
 199         last if ($match_type);
 200
 201         my $mtype;
 202         if ($mirror_continent eq $continent) {
 203             $mtype = 'continent';
 204         } else {
 205             $mtype = 'nearby-continent';
 206         }
 207
 208         for my $mirror (@mirrors) {
 209             next unless ($server_geoloc->{$mirror}{continent} eq $mirror_continent);
 210             $match_type = $mtype;
 211             consider_mirror($mirror);
 212         }
 213     }
 214 }
 215
 216 # something went awry, we don't know how to handle this user, we failed
 217 if (!$match_type) {
 218     print "Status: 503 Service Unavailable\r\n\r\n";
 219     exit;
 220 }
 221
 222
 223 my @sorted_hosts = sort { $hosts{$a} <=> $hosts{$b} } keys %hosts;
 224 my @close_hosts;
 225 my $dev;
 226
 227 my @iq_dists = map { $hosts{$_} } Mirror::Math::iquartile(@sorted_hosts);
 228 $dev = Mirror::Math::stddev(@iq_dists);
 229
 230 # Closest host (or one of many), to use as the base distance
 231 my $host = $sorted_hosts[0];
 232
 233 print_xtra('Std-Dev', $dev);
 234 print_xtra('Population', scalar(@sorted_hosts));
 235 print_xtra('Closest-Distance', $hosts{$host});
 236
 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;
 243     } else {
 244         # the list is sorted, if we didn't accept this one won't accept
 245         # the next
 246         last;
 247     }
 248 }
 249
 250 if ($random_sort) {
 251     my $n = int(rand scalar(@close_hosts));
 252     $host = $close_hosts[$n];
 253 }
 254 print_xtra('Distance', $hosts{$host});
 255 print_xtra('Match-Type', $match_type);
 256
 257 if ($action eq 'redir') {
 258     print "Content-type: text/plain\r\n";
 259     print "Status: 302 Moved Temporarily\r\n";
 260
 261     my $port = 9094;
 262     if ($host eq '2001:67c:29f4::50' || $host eq '193.35.52.50') {
 263         $port = 9095;
 264     }
 265     if ($host =~ /:/) {
 266         print "Location: http://[".$host."]:$port/".$url."\r\n";
 267     } else {
 268         print "Location: http://".$host.":$port/".$url."\r\n";
 269     }
 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";
 279     }
 280 } else {
 281     die("FIXME: unknown action '$action'");
 282 }
 283
 284 print "\r\n";
 285
 286 for my $line (@output) {
 287     print $line;
 288 }
 289
 290 exit;
 291
 292 sub print_xtra($$) {
 293     print "X-$_[0]: $_[1]\r\n"
 294         if ($xtra_headers);
 295 }
 296
 297 sub clean_url($) {
 298     my $url = shift;
 299     $url =~ s,//,/,g;
 300     $url =~ s,^/,,;
 301     $url =~ s,^\.\.?/,,g;
 302     $url =~ s,(?<=/)\.\.?(?:/|$),,g;
 303     $url = CGI::Simple->url_encode($url);
 304     $url =~ s,%2F,/,g;
 305     return $url;
 306 }
 307
 308 sub consider_mirror($) {
 309     my ($ip) = @_;
 310
 311     my $geoloc = $server_geoloc->{$ip};
 312
 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'});
 318
 319     $hosts{$ip} = Math::Trig::great_circle_distance($lon1, $lat1, $lon2, $lat2);
 320 }
 321
 322 sub geolocate($) {
 323     my ($IP) = @_;
 324
 325     our $ipv6 = ($IP =~ m/:/);
 326
 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;
 330         $ipv6 = 0;
 331         print_xtra('IPv6', $IP);
 332
 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));
 339         }
 340     }
 341
 342     my ($g_city, $g_as);
 343     my ($geo_rec, $as);
 344     our ($lat, $lon);
 345
 346     if (!$ipv6) {
 347         $g_city = Geo::IP->open('geoip/GeoLiteCity.dat', GEOIP_MMAP_CACHE);
 348         $g_as = Geo::IP->open('geoip/GeoIPASNum.dat', GEOIP_MMAP_CACHE);
 349
 350         $geo_rec = $g_city->record_by_addr($IP);
 351         ($as) = split /\s+/, ($g_as->org_by_addr($IP) || ' ');
 352     } else {
 353         $g_city = Geo::IP->open('geoip/GeoLiteCityv6.dat', GEOIP_MMAP_CACHE);
 354         $g_as = Geo::IP->open('geoip/GeoIPASNumv6.dat', GEOIP_MMAP_CACHE);
 355
 356         $geo_rec = $g_city->record_by_addr_v6($IP);
 357         ($as) = split /\s+/, ($g_as->org_by_addr_v6($IP) || ' ');
 358     }
 359
 360     if (!defined($geo_rec)) {
 361         return {
 362             ip => $IP,
 363             as => 0,
 364             country => '--',
 365             continent => 'EU',
 366             lon => 0.0,
 367             lat => 0.0,
 368         };
 369     }
 370
 371     $as = Mirror::AS::convert($as);
 372
 373     $lat = $geo_rec->latitude;
 374     $lon = $geo_rec->longitude;
 375
 376     my $continent = $geo_rec->continent_code;
 377     $continent = 'EU' if ($continent eq '--');
 378
 379     return {
 380         ip => $IP,
 381         as => $as,
 382         country => $geo_rec->country_code,
 383         continent => $continent,
 384         lon => $lon,
 385         lat => $lat,
 386     };
 387 }