package mirror; use diagnostics; use strict; use feature 'state'; use common; use log; =head1 SYNOPSYS B 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; #- FIXME! (blino) we use use https here my $list = "http://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;