package urpm::mirrors;
use strict;
use urpm::util qw(cat_ find output_safe reduce_pathname);
use urpm::msg;
use urpm::download;
=head1 NAME
urpm::mirrors - Mirrors routines for urpmi
=head1 SYNOPSIS
=head1 DESCRIPTION
=over
=item try($urpm, $medium, $try)
$medium fields used: mirrorlist, with-dir
=cut
#- side-effects: $medium->{url}
#- + those of _pick_one ($urpm->{mirrors_cache})
sub try {
my ($urpm, $medium, $try) = @_;
for (my $nb = 1; $nb < $urpm->{options}{'max-round-robin-tries'}; $nb++) {
my $url = _pick_one($urpm, $medium->{mirrorlist}, $nb == 1, '') or return;
$urpm->{info}(N("trying again with mirror %s", $url)) if $nb > 1;
$medium->{url} = _add__with_dir($url, $medium->{'with-dir'});
$try->() and return 1;
black_list($urpm, $medium->{mirrorlist}, $url);
}
0;
}
=item try_probe($urpm, $medium, $try)
Similar to try() above, but failure is "normal" (useful when we lookup
a file)
$medium fields used: mirrorlist, with-dir
=cut
#- side-effects: $medium->{url}
#- + those of list_urls ($urpm->{mirrors_cache})
sub try_probe {
my ($urpm, $medium, $try) = @_;
my $nb = 0;
foreach my $mirror (map { @$_ } list_urls($urpm, $medium, '')) {
$nb++ < $urpm->{options}{'max-round-robin-probes'} or last;
my $url = $mirror->{url};
$nb > 1 ? $urpm->{info}(N("trying again with mirror %s", $url))
: $urpm->{log}("using mirror $url");
$medium->{url} = _add__with_dir($url, $medium->{'with-dir'});
$try->() and return 1;
}
0;
}
#- side-effects: none
sub _add__with_dir {
my ($url, $with_dir) = @_;
reduce_pathname($url . ($with_dir ? "/$with_dir" : ''));
}
#- side-effects: $medium->{url}
#- + those of _pick_one ($urpm->{mirrors_cache})
sub pick_one {
my ($urpm, $medium, $allow_cache_update) = @_;
my $url = _pick_one($urpm, $medium->{mirrorlist}, 'must_succeed', $allow_cache_update);
$medium->{url} = _add__with_dir($url, $medium->{'with-dir'});
}
#- side-effects:
#- + those of _pick_one_ ($urpm->{mirrors_cache})
sub list_urls {
my ($urpm, $medium, $allow_cache_update) = @_;
my @l = split(' ', $medium->{mirrorlist});
map {
my $cache = _pick_one_($urpm, $_, $allow_cache_update, $_ ne $l[-1]);
$cache ? $cache->{list} : [];
} @l;
}
#- side-effects: $urpm->{mirrors_cache}
sub _pick_one {
my ($urpm, $mirrorlists, $must_succeed, $allow_cache_update) = @_;
my @l = split(' ', $mirrorlists);
foreach my $mirrorlist (@l) {
if (my $cache = _pick_one_($urpm, $mirrorlist, $allow_cache_update, $mirrorlist ne $l[-1])) {
if ($cache->{nb_uses}++) {
$urpm->{debug} and $urpm->{debug}("using mirror $cache->{chosen}");
} else {
$urpm->{log}("using mirror $cache->{chosen}");
}
return $cache->{chosen};
}
}
$must_succeed and $urpm->{fatal}(10, N("Could not find a mirror from mirrorlist %s", $mirrorlists));
undef;
}
#- side-effects: $urpm->{mirrors_cache}
sub _pick_one_ {
my ($urpm, $mirrorlist, $allow_cache_update, $set_network_mtime) = @_;
my $cache = _cache__may_clean_if_outdated($urpm, $mirrorlist, $allow_cache_update);
if (!$cache->{chosen}) {
if (!$cache->{list}) {
if (_is_only_one_mirror($mirrorlist)) {
$cache->{list} = [ { url => $mirrorlist } ];
} else {
$cache->{list} = [ _list($urpm, $mirrorlist) ];
}
$cache->{time} = time();
# the cache will be deemed outdated if network_mtime is more recent than the cache's
$cache->{network_mtime} = _network_mtime() if $set_network_mtime;
$cache->{product_id_mtime} = _product_id_mtime();
}
if (-x '/usr/bin/rsync') {
$cache->{chosen} = $cache->{list}[0]{url};
} else {
my $m = find { $_->{url} !~ m!^rsync://! } @{$cache->{list}};
$cache->{chosen} = $m->{url};
}
$cache->{chosen} or return;
_save_cache($urpm);
}
$cache;
}
#- side-effects: $urpm->{mirrors_cache}
sub black_list {
my ($urpm, $mirrorlists, $url) = @_;
foreach my $mirrorlist (split ' ', $mirrorlists) {
my $cache = _cache($urpm, $mirrorlist);
if ($cache->{list}) {
@{$cache->{list}} = grep { $_->{url} ne $url } @{$cache->{list}};
}
delete $cache->{chosen};
}
}
sub _trigger_cache_update {
my ($urpm, $cache, $o_is_upgrade) = @_;
my $reason = $o_is_upgrade ? "reason=upgrade" : "reason=update";
$urpm->{log}("URPMI_ADDMEDIA_REASON $reason");
$ENV{URPMI_ADDMEDIA_REASON} = $reason;
%$cache = ();
}
#- side-effects:
#- + those of _cache ($urpm->{mirrors_cache})
sub _cache__may_clean_if_outdated {
my ($urpm, $mirrorlist, $allow_cache_update) = @_;
my $cache = _cache($urpm, $mirrorlist);
if ($allow_cache_update) {
if ($cache->{network_mtime} && _network_mtime() > $cache->{network_mtime}) {
$urpm->{log}("not using cached mirror list $mirrorlist since network configuration changed");
_trigger_cache_update($urpm, $cache);
} elsif ($cache->{time} &&
time() > $cache->{time} + 24*60*60 * $urpm->{options}{'days-between-mirrorlist-update'}) {
$urpm->{log}("not using outdated cached mirror list $mirrorlist");
_trigger_cache_update($urpm, $cache);
} elsif (!$cache->{product_id_mtime}) {
$urpm->{log}("cached mirror list uses an old format, invalidating it");
_trigger_cache_update($urpm, $cache, 1);
} elsif ($cache->{product_id_mtime} && _product_id_mtime() != $cache->{product_id_mtime}) {
$urpm->{log}("not using cached mirror list $mirrorlist since product id file changed");
_trigger_cache_update($urpm, $cache, 1);
}
}
$cache;
}
#- side-effects: $urpm->{mirrors_cache}
sub _cache {
my ($urpm, $mirrorlist) = @_;
my $full_cache = $urpm->{mirrors_cache} ||= _load_cache($urpm);
$full_cache->{$mirrorlist} ||= {};
}
sub cache_file {
my ($urpm) = @_;
"$urpm->{cachedir}/mirrors.cache";
}
sub _load_cache {
my ($urpm) = @_;
my $cache;
if (-e cache_file($urpm)) {
$urpm->{debug} and $urpm->{debug}("loading mirrors cache");
$cache = eval(cat_(cache_file($urpm)));
$@ and $urpm->{error}("failed to read " . cache_file($urpm) . ": $@");
$_->{nb_uses} = 0 foreach values %$cache;
}
if ($ENV{URPMI_ADDMEDIA_PRODUCT_VERSION} && delete $cache->{'$MIRRORLIST'}) {
$urpm->{log}('not using cached mirror list $MIRRORLIST since URPMI_ADDMEDIA_PRODUCT_VERSION is set');
}
$cache || {};
}
sub _save_cache {
my ($urpm) = @_;
require Data::Dumper;
my $s = Data::Dumper::Dumper($urpm->{mirrors_cache});
$s =~ s/.*?=//; # get rid of $VAR1 =
output_safe(cache_file($urpm), $s);
}
#- side-effects: none
sub _list {
my ($urpm, $mirrorlist) = @_;
my @mirrors = _mirrors_filtered($urpm, _expand($mirrorlist));
add_proximity_and_sort($urpm, \@mirrors);
@mirrors;
}
sub _expand {
my ($mirrorlist) = @_;
# expand the variables
if ($mirrorlist eq '$MIRRORLIST') {
_MIRRORLIST();
} else {
require urpm::cfg;
urpm::cfg::expand_line($mirrorlist);
}
}
#- side-effects: $mirrors
sub add_proximity_and_sort {
my ($urpm, $mirrors) = @_;
my ($latitude, $longitude, $country_code);
require Time::ZoneInfo;
if (my $zone = Time::ZoneInfo->current_zone) {
if (my $zones = Time::ZoneInfo->new) {
if (($latitude, $longitude) = $zones->latitude_longitude_decimal($zone)) {
$country_code = $zones->country($zone);
$urpm->{log}(N("found geolocalisation %s %.2f %.2f from timezone %s", $country_code, $latitude, $longitude, $zone));
}
}
}
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;
}
@$mirrors = sort { $a->{proximity_corrected} <=> $b->{proximity_corrected} } @$mirrors;
}
# 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 _mirrors_raw {
my ($urpm, $url) = @_;
$urpm->{log}(N("getting mirror list from %s", $url));
my @l = urpm::download::get_content($urpm, $url, disable_metalink => 1) or $urpm->{error}("mirror list not found");
@l;
}
sub _mirrors_filtered {
my ($urpm, $mirrorlist) = @_;
grep {
$_->{type} eq 'distrib'; # type=updates seems to be history, and type=iso is not interesting here
} map { chomp; parse_LDAP_namespace_structure($_) } _mirrors_raw($urpm, $mirrorlist);
}
sub _MIRRORLIST() {
my $product_id = parse_LDAP_namespace_structure(cat_('/etc/product.id'));
_mageia_mirrorlist($product_id);
}
sub _mageia_mirrorlist {
my ($product_id, $o_arch) = @_;
#- contact the following URL to retrieve the list of mirrors.
#- http://wiki.mandriva.com/en/Product_id
my $_product_type = lc($product_id->{type}); $product_id =~ s/\s//g;
my $arch = $o_arch || $product_id->{arch};
my @para = grep { $_ } $ENV{URPMI_ADDMEDIA_REASON};
my $product_version = $ENV{URPMI_ADDMEDIA_PRODUCT_VERSION} || $product_id->{version};
#"http://mirrors.mageia.org/api/$product_type.$product_version.$arch.list"
"http://mirrors.mageia.org/api/mageia.$product_version.$arch.list"
. (@para ? '?' . join('&', @para) : '');
}
#- heuristic to detect wether it is really a mirrorlist or a simple mirror url:
sub _is_only_one_mirror {
my ($mirrorlist) = @_;
_expand($mirrorlist) !~ /\.list(\?|$)/;
}
sub _network_mtime() { (stat('/etc/resolv.conf'))[9] }
sub _product_id_mtime() { (stat('/etc/product.id'))[9] }
sub parse_LDAP_namespace_structure {
my ($s) = @_;
my %h = map { /(.*?)=(.*)/ ? ($1 => $2) : @{[]} } split(',', $s);
\%h;
}
1;
__END__
=back
=head1 COPYRIGHT
Copyright (C) 2005 MandrakeSoft SA
Copyright (C) 2005-2010 Mandriva SA
=cut