Rework mirror::nearest() to use the same algorithm as urpm::mirrors.

The old code never really worked. At best it would return a mirror
at the same longitude, but usually it returned a random result.

2 files changed, 62 insertions, 10 deletions

diff --git a/perl-install/install/share/list.xml b/perl-install/install/share/list.xml
index fcab1be9b..e8b6273ce 100644
--- a/perl-install/install/share/list.xml
+++ b/perl-install/install/share/list.xml
@@ -236,6 +236,10 @@
   iso8859-1
 </from>
 
+<from dir="/usr/share/zoneinfo">
+  zone.tab
+</from>
+
 <filter command="strip">
 <from dir="/LIB">
   libnss_files.so.2
@@ -623,6 +627,7 @@
   MDV/Snapshot/Restore.pm
   Parse/EDID.pm
   String/ShellQuote.pm
+  Time/ZoneInfo.pm
   XML/SAX/Exception.pm
   urpm.pm
   urpm/args.pm
diff --git a/perl-install/mirror.pm b/perl-install/mirror.pm
index 654bdb2e9..33dbe1c9c 100644
--- a/perl-install/mirror.pm
+++ b/perl-install/mirror.pm
@@ -158,20 +158,67 @@ Randomly returns one of the nearest mirror
 
 =cut
 
+#- TODO: The following code was forked from urpm::mirrors. Consider refactoring.
+
 sub nearest {
     my ($timezone, $mirrors) = @_;
 
-    my (@country, @zone);
-    foreach my $mirror (@$mirrors) {
-	my @tzs = @{$land2tzs{$mirror->{country}} || []};
-	eval { push @{$country[find_index { $_ eq $timezone } @tzs]}, $mirror };
-	eval { push @{$zone[find_index { ((split '/')[0] eq (split '/', $timezone)[0]) } @tzs]}, $mirror };
+    my ($latitude, $longitude, $country_code);
+
+    require Time::ZoneInfo;
+    if (my $zones = Time::ZoneInfo->new) {
+        if (($latitude, $longitude) = $zones->latitude_longitude_decimal($timezone)) {
+            $country_code = $zones->country($timezone);
+        }
+    }
+    defined $latitude && defined $longitude or return;
+
+    foreach (@$mirrors) {
+        $_->{latitude} || $_->{longitude} or next;
+        my $PI = 3.14159265358979;
+        my $x = $latitude - $_->{latitude};
+        my $y = ($longitude - $_->{longitude}) * cos($_->{latitude} / 180 * $PI);
+        $_->{proximity} = sqrt($x * $x + $y * $y);
     }
-    my @l = @country ? @country : @zone;
-    shift @l while !$l[0] && @l;
-    
-    my @possible = @l ? ((@{$l[0]}) x 2, @{$l[1] || []}) : @$mirrors;
-    $possible[rand @possible];
+    my ($best) = sort { $a->{proximity} <=> $b->{proximity} } @$mirrors;
+
+    foreach (@$mirrors) {
+        $_->{proximity_corrected} = $_->{proximity} * _random_correction();
+        $_->{proximity_corrected} *= _between_country_correction($country_code, $_->{country}) if $best;
+        $_->{proximity_corrected} *= _between_continent_correction($best->{continent}, $_->{continent}) if $best;
+        $_->{proximity_corrected} *= _protocol_correction($_->{url});
+    }
+    ($best) = sort { $a->{proximity_corrected} <=> $b->{proximity_corrected} } @$mirrors;
+    $best;
+}
+
+# add +/- 5% random
+sub _random_correction() {
+    my $correction = 0.05;
+    1 + (rand() - 0.5) * $correction * 2;
+}
+
+sub _between_country_correction {
+    my ($here, $mirror) = @_;
+    $here && $mirror or return 1;
+    $here eq $mirror ? 0.5 : 1;
+}
+
+sub _between_continent_correction {
+    my ($here, $mirror) = @_;
+    $here && $mirror or return 1;
+    $here eq $mirror ? 0.5 : # favor same continent
+      $here eq 'SA' && $mirror eq 'NA' ? 0.9 : # favor going "South America" -> "North America"
+	1;
+}
+
+sub _protocol_correction {
+    my ($url) = @_;
+    # favor encrypted protocols, then http
+    ( $url =~ m!https://! ) and return 0.7;
+    ( $url =~ m!ftps://! ) and return 0.8;
+    ( $url =~ m!http://! ) and return 0.9;
+    1;
 }
 
 =back