1 files changed, 192 insertions, 0 deletions

diff --git a/perl-install/mirror.pm b/perl-install/mirror.pm
new file mode 100644
index 000000000..11d55f06b
--- /dev/null
+++ b/perl-install/mirror.pm
@@ -0,0 +1,192 @@
+package mirror;
+
+use diagnostics;
+use strict;
+use feature 'state';
+
+use common;
+use log;
+
+=head1 SYNOPSYS
+
+B<mirror> enables to manage Mageia distribution mirrors
+
+=head1 Functions
+
+=over
+
+=cut
+
+=item mirror2text($mirror)
+
+Returns a displayable string from a mirror struct
+
+=cut
+
+sub mirror2text {
+    my ($mirror) = @_;
+    translate($mirror->{country})  . '|' . $mirror->{host} . ($mirror->{method} ? " ($mirror->{method})" : '');
+}
+
+=item register_downloader($func)
+
+Sets a downloader program
+
+=cut
+
+my $downloader;
+sub register_downloader {
+    my ($func) = @_;
+    $downloader = $func;
+}
+
+sub _mirrors_raw_install {
+    my ($list) = @_;
+    require install::http;
+    my $f = install::http::getFile($list, "strict-certificate-check" => 1) or die "mirror list not found";
+    local $SIG{ALRM} = sub { die "timeout" };
+    alarm 60;
+    log::l("using mirror list $list");
+    my @lines;
+    push @lines, $_ while <$f>;
+    alarm 0;
+    @lines;
+}
+
+sub _mirrors_raw_standalone {
+    my ($list) = @_;
+    my @lines;
+    if (ref($downloader)) {
+        @lines = $downloader->($list);
+        @lines or die "mirror list not found";
+    } else {
+        die "Missing download callback";
+    }
+    @lines;
+}
+
+=item mirrors_raw($product_id)
+
+Returns a list of mirrors hash refs from http://mirrors.mageia.org
+
+Note that in standalone mode, one has to actually use register_downloader()
+first in order to provide a downloader callback.
+
+=cut
+
+sub mirrors_raw {
+    my ($product_id) = @_;
+
+    #- contact the following URL to retrieve the list of mirrors.
+    #- http://wiki.mageia.org/en/Product_id
+    my $type = lc($product_id->{type}); $type =~ s/\s//g;
+    my $list = "https://mirrors.mageia.org/api/$type.$product_id->{version}.$product_id->{arch}.list?product=$product_id->{product}";
+    log::explanations("trying mirror list from $list");
+    my @lines = $::isInstall ? _mirrors_raw_install($list) : _mirrors_raw_standalone($list);
+    map { common::parse_LDAP_namespace_structure(chomp_($_)) } @lines;
+}
+
+=item list($product_id, $type)
+
+
+Returns a list of mirrors hash refs as returned by mirrors_raw() but filters it.
+
+One can select the type of mirrors ('distrib', 'updates', ...) or 'all'
+
+=cut
+
+sub list {
+    my ($product_id, $type) = @_;
+
+    our @mirrors_raw;
+    if (!@mirrors_raw) {
+        @mirrors_raw = eval { mirrors_raw($product_id) };
+        if (my $err = $@) {
+            log::explanations("failed to download mirror list");
+            die $err;
+        }
+        @mirrors_raw or log::explanations("empty mirror list"), return;
+    }
+
+	my @mirrors = grep {
+	    ($_->{method}, $_->{host}, $_->{dir}) = $_->{url} =~ m!^(ftp|https?)://(.*?)(/.*)!;
+	    $_->{method} && (member($type, 'all', $_->{type}));
+	} @mirrors_raw or log::explanations("no mirrors of type $type"), return;
+
+    @mirrors && \@mirrors;
+}
+
+=item nearest($timezone, $mirrors)
+
+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 ($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 ($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
+
+=cut
+
+1;