diff options
Diffstat (limited to 'perl-install/mirror.pm')
| -rw-r--r-- | perl-install/mirror.pm | 192 |
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; |