├── .gitignore ├── .gitmodules ├── Mirror ├── AS.pm ├── CountryCoords.pm ├── DB.pm ├── Fake │ └── Geoip │ │ └── Record.pm ├── FallbackGeoLocation.pm ├── Math.pm ├── RateLimiter.pm ├── Redirection │ ├── Blackhole.pm │ └── Permanent.pm ├── Redirector.pm ├── Request.pm └── Trace.pm ├── README.md ├── app-proxy.psgi ├── app.psgi ├── build-main-db.pl ├── build-peers-db.pl ├── build-report.pl ├── check.pl ├── demo.html ├── dump-db.pl ├── extract-peers.pl ├── import-dump.pl ├── local-request.pl ├── mirrors.lst.d └── .gitkeep ├── peers.lst.d └── .gitkeep ├── t └── Mirror │ ├── AS │ ├── 00-use.t │ └── 01-convert.t │ ├── CountryCoords │ ├── 00-use.t │ └── 01-coords-for-country.t │ ├── DB │ ├── 00-use.t │ ├── 01-store.t │ └── 02-store-shared.t │ ├── Fake │ └── Geoip │ │ └── Record │ │ ├── 00-use.t │ │ └── 01-set-and-get.t │ ├── FallbackGeoLocation │ ├── 00-use.t │ ├── 01-get_record.t │ └── 02-caching.t │ ├── Math │ ├── 00-use.t │ ├── 01-stddev.t │ ├── 01-stddevp.t │ ├── 02-distance.t │ ├── 03-stddev-precision.t │ └── 04-quartiles.t │ ├── RateLimiter │ ├── 00-use.t │ ├── 01-new.t │ ├── 02-skip.t │ ├── 03-tolerance.t │ ├── 04-load-store-load.t │ ├── 05-failure-attempts-ratio.t │ ├── 06-auto-success.t │ ├── 07-multiple-failures.t │ ├── 08-just-a-lookup.t │ ├── 09-auto-success-on-auto-save.t │ └── 20-errors.t │ ├── Redirection │ ├── Blackhole │ │ ├── 00-use.t │ │ ├── 01-should_blackhole.t │ │ ├── 02-blackhole-for-jessie.t │ │ ├── 02-blackhole-for-lts.t │ │ └── 03-blackhole-for-sid.t │ └── Permanent │ │ ├── 00-use.t │ │ └── 01-is_permanent.t │ ├── Redirector │ ├── 00-app.t │ ├── 01-demo.t │ ├── 01-list.t │ ├── 02-forbidden-methods.t │ ├── 03-per-request-state.t │ ├── 04-modifying-globals.t │ ├── 05-url-cleanup.t │ ├── 06-default-ip-for-tests.t │ ├── 06-set-local-ip.t │ ├── 07-multiple-link-headers.t │ ├── 08-region-and-city.t │ ├── 09-blackholed-requests.t │ └── 09-permanent-redirections.t │ ├── Request │ ├── 00-use.t │ └── 01-architecture.t │ └── Trace │ ├── 00-use.t │ ├── 01-new.t │ ├── 02-can-interface.t │ ├── 03-parse-master-trace.t │ ├── 03-parse-trace.t │ ├── 04-parse-empty-trace.t │ ├── 04-parse-ftpsync-20120521.t │ ├── 04-parse-ftpsync-20160306.t │ ├── 05-ftpsync-features.t │ ├── 06-architectures-field.t │ ├── 06-bogus-architectures-field.t │ ├── 06-empty-architectures-field.t │ ├── 07-revision-field.t │ ├── 90-broken-ftpsync-version.t │ └── 91-GMT0-date-in-trace.t ├── translate-log.pl └── update.sh /.gitignore: -------------------------------------------------------------------------------- 1 | db 2 | db.peers-* 3 | mirrors.lst.d/*.masterlist* 4 | geoip 5 | tmon.out 6 | nytprof* 7 | peers.lst.d/*.lst 8 | bgp/latest-bview.gz 9 | bgp/zdp-stdout-* 10 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "bgp/zebra-dump-parser"] 2 | path = bgp/zebra-dump-parser 3 | url = https://github.com/rgeissert/zebra-dump-parser.git 4 | branch = httpredir-config 5 | -------------------------------------------------------------------------------- /Mirror/AS.pm: -------------------------------------------------------------------------------- 1 | package Mirror::AS; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub convert { 7 | my $as = shift; 8 | 9 | $as =~ s/^AS//; 10 | 11 | if ($as =~ m/(\d+)\.(\d+)/) { 12 | $as = unpack('N', pack('nn', $1, $2)); 13 | } 14 | 15 | return $as; 16 | } 17 | 18 | 1; 19 | -------------------------------------------------------------------------------- /Mirror/CountryCoords.pm: -------------------------------------------------------------------------------- 1 | package Mirror::CountryCoords; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use vars qw(%countries); 7 | 8 | sub country { 9 | my $country = shift; 10 | 11 | return $countries{$country} 12 | if (exists($countries{$country})); 13 | 14 | while () { 15 | chomp; 16 | next if (m/^\s*(?:#|$)/); 17 | 18 | my ($c, $lat, $lon) = split(/:/); 19 | $countries{$c} = { 'lat' => $lat, 'lon' => $lon}; 20 | 21 | last if ($country eq $c); 22 | } 23 | return $countries{$country}; 24 | } 25 | 26 | 1; 27 | __DATA__ 28 | # Data in public domain from the CIA's World Factbook, 29 | # extracted by Maxmind, Inc. 30 | 31 | AD:42.5000:1.5000 32 | AE:24.0000:54.0000 33 | AF:33.0000:65.0000 34 | AG:17.0500:-61.8000 35 | AI:18.2500:-63.1667 36 | AL:41.0000:20.0000 37 | AM:40.0000:45.0000 38 | AN:12.2500:-68.7500 39 | AO:-12.5000:18.5000 40 | AP:35.0000:105.0000 41 | AQ:-90.0000:0.0000 42 | AR:-34.0000:-64.0000 43 | AS:-14.3333:-170.0000 44 | AT:47.3333:13.3333 45 | AU:-27.0000:133.0000 46 | AW:12.5000:-69.9667 47 | AZ:40.5000:47.5000 48 | BA:44.0000:18.0000 49 | BB:13.1667:-59.5333 50 | BD:24.0000:90.0000 51 | BE:50.8333:4.0000 52 | BF:13.0000:-2.0000 53 | BG:43.0000:25.0000 54 | BH:26.0000:50.5500 55 | BI:-3.5000:30.0000 56 | BJ:9.5000:2.2500 57 | BM:32.3333:-64.7500 58 | BN:4.5000:114.6667 59 | BO:-17.0000:-65.0000 60 | BR:-10.0000:-55.0000 61 | BS:24.2500:-76.0000 62 | BT:27.5000:90.5000 63 | BV:-54.4333:3.4000 64 | BW:-22.0000:24.0000 65 | BY:53.0000:28.0000 66 | BZ:17.2500:-88.7500 67 | CA:60.0000:-95.0000 68 | CC:-12.5000:96.8333 69 | CD:0.0000:25.0000 70 | CF:7.0000:21.0000 71 | CG:-1.0000:15.0000 72 | CH:47.0000:8.0000 73 | CI:8.0000:-5.0000 74 | CK:-21.2333:-159.7667 75 | CL:-30.0000:-71.0000 76 | CM:6.0000:12.0000 77 | CN:35.0000:105.0000 78 | CO:4.0000:-72.0000 79 | CR:10.0000:-84.0000 80 | CU:21.5000:-80.0000 81 | CV:16.0000:-24.0000 82 | CX:-10.5000:105.6667 83 | CY:35.0000:33.0000 84 | CZ:49.7500:15.5000 85 | DE:51.0000:9.0000 86 | DJ:11.5000:43.0000 87 | DK:56.0000:10.0000 88 | DM:15.4167:-61.3333 89 | DO:19.0000:-70.6667 90 | DZ:28.0000:3.0000 91 | EC:-2.0000:-77.5000 92 | EE:59.0000:26.0000 93 | EG:27.0000:30.0000 94 | EH:24.5000:-13.0000 95 | ER:15.0000:39.0000 96 | ES:40.0000:-4.0000 97 | ET:8.0000:38.0000 98 | EU:47.0000:8.0000 99 | FI:64.0000:26.0000 100 | FJ:-18.0000:175.0000 101 | FK:-51.7500:-59.0000 102 | FM:6.9167:158.2500 103 | FO:62.0000:-7.0000 104 | FR:46.0000:2.0000 105 | GA:-1.0000:11.7500 106 | GB:54.0000:-2.0000 107 | GD:12.1167:-61.6667 108 | GE:42.0000:43.5000 109 | GF:4.0000:-53.0000 110 | GH:8.0000:-2.0000 111 | GI:36.1833:-5.3667 112 | GL:72.0000:-40.0000 113 | GM:13.4667:-16.5667 114 | GN:11.0000:-10.0000 115 | GP:16.2500:-61.5833 116 | GQ:2.0000:10.0000 117 | GR:39.0000:22.0000 118 | GS:-54.5000:-37.0000 119 | GT:15.5000:-90.2500 120 | GU:13.4667:144.7833 121 | GW:12.0000:-15.0000 122 | GY:5.0000:-59.0000 123 | HK:22.2500:114.1667 124 | HM:-53.1000:72.5167 125 | HN:15.0000:-86.5000 126 | HR:45.1667:15.5000 127 | HT:19.0000:-72.4167 128 | HU:47.0000:20.0000 129 | ID:-5.0000:120.0000 130 | IE:53.0000:-8.0000 131 | IL:31.5000:34.7500 132 | IN:20.0000:77.0000 133 | IO:-6.0000:71.5000 134 | IQ:33.0000:44.0000 135 | IR:32.0000:53.0000 136 | IS:65.0000:-18.0000 137 | IT:42.8333:12.8333 138 | JM:18.2500:-77.5000 139 | JO:31.0000:36.0000 140 | JP:36.0000:138.0000 141 | KE:1.0000:38.0000 142 | KG:41.0000:75.0000 143 | KH:13.0000:105.0000 144 | KI:1.4167:173.0000 145 | KM:-12.1667:44.2500 146 | KN:17.3333:-62.7500 147 | KP:40.0000:127.0000 148 | KR:37.0000:127.5000 149 | KW:29.3375:47.6581 150 | KY:19.5000:-80.5000 151 | KZ:48.0000:68.0000 152 | LA:18.0000:105.0000 153 | LB:33.8333:35.8333 154 | LC:13.8833:-61.1333 155 | LI:47.1667:9.5333 156 | LK:7.0000:81.0000 157 | LR:6.5000:-9.5000 158 | LS:-29.5000:28.5000 159 | LT:56.0000:24.0000 160 | LU:49.7500:6.1667 161 | LV:57.0000:25.0000 162 | LY:25.0000:17.0000 163 | MA:32.0000:-5.0000 164 | MC:43.7333:7.4000 165 | MD:47.0000:29.0000 166 | ME:42.0000:19.0000 167 | MG:-20.0000:47.0000 168 | MH:9.0000:168.0000 169 | MK:41.8333:22.0000 170 | ML:17.0000:-4.0000 171 | MM:22.0000:98.0000 172 | MN:46.0000:105.0000 173 | MO:22.1667:113.5500 174 | MP:15.2000:145.7500 175 | MQ:14.6667:-61.0000 176 | MR:20.0000:-12.0000 177 | MS:16.7500:-62.2000 178 | MT:35.8333:14.5833 179 | MU:-20.2833:57.5500 180 | MV:3.2500:73.0000 181 | MW:-13.5000:34.0000 182 | MX:23.0000:-102.0000 183 | MY:2.5000:112.5000 184 | MZ:-18.2500:35.0000 185 | NA:-22.0000:17.0000 186 | NC:-21.5000:165.5000 187 | NE:16.0000:8.0000 188 | NF:-29.0333:167.9500 189 | NG:10.0000:8.0000 190 | NI:13.0000:-85.0000 191 | NL:52.5000:5.7500 192 | NO:62.0000:10.0000 193 | NP:28.0000:84.0000 194 | NR:-0.5333:166.9167 195 | NU:-19.0333:-169.8667 196 | NZ:-41.0000:174.0000 197 | OM:21.0000:57.0000 198 | PA:9.0000:-80.0000 199 | PE:-10.0000:-76.0000 200 | PF:-15.0000:-140.0000 201 | PG:-6.0000:147.0000 202 | PH:13.0000:122.0000 203 | PK:30.0000:70.0000 204 | PL:52.0000:20.0000 205 | PM:46.8333:-56.3333 206 | PR:18.2500:-66.5000 207 | PS:32.0000:35.2500 208 | PT:39.5000:-8.0000 209 | PW:7.5000:134.5000 210 | PY:-23.0000:-58.0000 211 | QA:25.5000:51.2500 212 | RE:-21.1000:55.6000 213 | RO:46.0000:25.0000 214 | RS:44.0000:21.0000 215 | RU:60.0000:100.0000 216 | RW:-2.0000:30.0000 217 | SA:25.0000:45.0000 218 | SB:-8.0000:159.0000 219 | SC:-4.5833:55.6667 220 | SD:15.0000:30.0000 221 | SE:62.0000:15.0000 222 | SG:1.3667:103.8000 223 | SH:-15.9333:-5.7000 224 | SI:46.0000:15.0000 225 | SJ:78.0000:20.0000 226 | SK:48.6667:19.5000 227 | SL:8.5000:-11.5000 228 | SM:43.7667:12.4167 229 | SN:14.0000:-14.0000 230 | SO:10.0000:49.0000 231 | SR:4.0000:-56.0000 232 | ST:1.0000:7.0000 233 | SV:13.8333:-88.9167 234 | SY:35.0000:38.0000 235 | SZ:-26.5000:31.5000 236 | TC:21.7500:-71.5833 237 | TD:15.0000:19.0000 238 | TF:-43.0000:67.0000 239 | TG:8.0000:1.1667 240 | TH:15.0000:100.0000 241 | TJ:39.0000:71.0000 242 | TK:-9.0000:-172.0000 243 | TM:40.0000:60.0000 244 | TN:34.0000:9.0000 245 | TO:-20.0000:-175.0000 246 | TR:39.0000:35.0000 247 | TT:11.0000:-61.0000 248 | TV:-8.0000:178.0000 249 | TW:23.5000:121.0000 250 | TZ:-6.0000:35.0000 251 | UA:49.0000:32.0000 252 | UG:1.0000:32.0000 253 | UM:19.2833:166.6000 254 | US:38.0000:-97.0000 255 | UY:-33.0000:-56.0000 256 | UZ:41.0000:64.0000 257 | VA:41.9000:12.4500 258 | VC:13.2500:-61.2000 259 | VE:8.0000:-66.0000 260 | VG:18.5000:-64.5000 261 | VI:18.3333:-64.8333 262 | VN:16.0000:106.0000 263 | VU:-16.0000:167.0000 264 | WF:-13.3000:-176.2000 265 | WS:-13.5833:-172.3333 266 | YE:15.0000:48.0000 267 | YT:-12.8333:45.1667 268 | ZA:-29.0000:24.0000 269 | ZM:-15.0000:30.0000 270 | ZW:-20.0000:30.0000 271 | -------------------------------------------------------------------------------- /Mirror/DB.pm: -------------------------------------------------------------------------------- 1 | package Mirror::DB; 2 | 3 | use strict; 4 | use warnings; 5 | use Storable qw(); 6 | 7 | use vars qw($DB_FILE); 8 | 9 | sub set { 10 | $DB_FILE = shift; 11 | } 12 | 13 | sub store { 14 | my $db = shift; 15 | 16 | # Storable doesn't clone the tied hash as needed 17 | # so we have do it the ugly way: 18 | my $VAR1; 19 | { 20 | use Data::Dumper; 21 | $Data::Dumper::Purity = 1; 22 | $Data::Dumper::Indent = 0; 23 | 24 | my $clone = Dumper($db); 25 | eval $clone; 26 | } 27 | 28 | Storable::store ($VAR1, $DB_FILE.'.new') 29 | or die ("failed to store to $DB_FILE.new: $!"); 30 | rename ($DB_FILE.'.new', $DB_FILE) 31 | or die("failed to rename $DB_FILE.new: $!"); 32 | 33 | } 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /Mirror/Fake/Geoip/Record.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Fake::Geoip::Record; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | my $self = {}; 9 | 10 | my %data; 11 | { 12 | my $even = 1; 13 | my $key = ''; 14 | 15 | foreach my $elem (@_) { 16 | if ($even) { 17 | $even = 0; 18 | $key = $elem; 19 | } else { 20 | $even = 1; 21 | $data{$key} = $elem; 22 | } 23 | } 24 | } 25 | $self->{'data'} = \%data; 26 | 27 | bless ($self, $class); 28 | return $self; 29 | } 30 | 31 | sub latitude { 32 | my $self = shift; 33 | return $self->{'data'}->{'latitude'}; 34 | } 35 | 36 | sub longitude { 37 | my $self = shift; 38 | return $self->{'data'}->{'longitude'}; 39 | } 40 | 41 | sub country_code { 42 | my $self = shift; 43 | return $self->{'data'}->{'country_code'}; 44 | } 45 | 46 | sub continent_code { 47 | my $self = shift; 48 | return $self->{'data'}->{'continent_code'}; 49 | } 50 | 51 | sub city { 52 | my $self = shift; 53 | return $self->{'data'}->{'city'} || ''; 54 | } 55 | 56 | sub region { 57 | my $self = shift; 58 | return $self->{'data'}->{'region'} || ''; 59 | } 60 | 61 | 1; 62 | -------------------------------------------------------------------------------- /Mirror/FallbackGeoLocation.pm: -------------------------------------------------------------------------------- 1 | package Mirror::FallbackGeoLocation; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Mirror::CountryCoords; 7 | use Mirror::Fake::Geoip::Record; 8 | 9 | use vars qw(%fake_records); 10 | 11 | sub get_record; 12 | sub get_continents_by_mirror_type; 13 | sub get_countries_by_mirror_type; 14 | sub get_continents_index; 15 | sub get_countries_index; 16 | sub is_enabled; 17 | 18 | sub get_record { 19 | my ($db, $type) = @_; 20 | 21 | return $fake_records{$type} 22 | if (defined($fake_records{$type})); 23 | 24 | my $chosen_continent; 25 | { 26 | my $max_mirrors = 0; 27 | my %continents; 28 | for my $continent (get_continents_by_mirror_type($db, $type)) { 29 | $continents{$continent} = scalar(keys %{get_continents_index($db, $type, $continent)}); 30 | } 31 | for my $continent (sort { $continents{$b} <=> $continents{$a} } keys %continents) { 32 | my @mirrors = keys %{get_continents_index($db, $type, $continent)}; 33 | 34 | next if (scalar(@mirrors) < $max_mirrors); 35 | 36 | my $c = 0; 37 | for my $id (@mirrors) { 38 | $c++ if (is_enabled($db, $type, $id)); 39 | } 40 | if ($c > $max_mirrors) { 41 | $max_mirrors = $c; 42 | $chosen_continent = $continent; 43 | } 44 | } 45 | } 46 | 47 | my $chosen_country; 48 | { 49 | my $max_mirrors = 0; 50 | my %countries; 51 | my $continent_index = get_continents_index($db, $type, $chosen_continent); 52 | for my $country (get_countries_by_mirror_type($db, $type)) { 53 | $countries{$country} = scalar(keys %{get_countries_index($db, $type, $country)}); 54 | } 55 | for my $country (sort { $countries{$b} <=> $countries{$a} } keys %countries) { 56 | my @mirrors = keys %{get_countries_index($db, $type, $country)}; 57 | 58 | next unless (defined($mirrors[0]) && exists($continent_index->{$mirrors[0]})); 59 | next if (scalar(@mirrors) < $max_mirrors); 60 | 61 | my $c = 0; 62 | for my $id (@mirrors) { 63 | $c++ if (is_enabled($db, $type, $id)); 64 | } 65 | if ($c > $max_mirrors) { 66 | $max_mirrors = $c; 67 | $chosen_country = $country; 68 | } 69 | } 70 | } 71 | 72 | my $ltln = Mirror::CountryCoords::country($chosen_country); 73 | my $rec = Mirror::Fake::Geoip::Record->new( 74 | country_code => $chosen_country, 75 | continent_code => $chosen_continent, 76 | latitude => $ltln->{'lat'}, 77 | longitude => $ltln->{'lon'}, 78 | city => 'fallback', 79 | region => 'fallback', 80 | ); 81 | $fake_records{$type} = $rec; 82 | return $fake_records{$type}; 83 | } 84 | 85 | sub get_continents_by_mirror_type { 86 | my ($db, $type) = @_; 87 | 88 | return keys %{$db->{$type}{'continent'}}; 89 | } 90 | 91 | sub get_countries_by_mirror_type { 92 | my ($db, $type) = @_; 93 | 94 | return keys %{$db->{$type}{'country'}}; 95 | } 96 | 97 | sub get_continents_index { 98 | my ($db, $type, $continent) = @_; 99 | return $db->{$type}{'continent'}{$continent}; 100 | } 101 | 102 | sub get_countries_index { 103 | my ($db, $type, $country) = @_; 104 | return $db->{$type}{'country'}{$country}; 105 | } 106 | 107 | sub is_enabled { 108 | my ($db, $type, $id) = @_; 109 | return !exists($db->{'all'}{$id}{$type.'-disabled'}); 110 | } 111 | 112 | 1; 113 | -------------------------------------------------------------------------------- /Mirror/Math.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Math; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use POSIX qw(ceil); 7 | use vars qw($METRIC); 8 | 9 | BEGIN { 10 | $METRIC = 'taxicab'; 11 | } 12 | 13 | sub set_metric($) { 14 | $METRIC = shift; 15 | } 16 | 17 | sub calculate_distance($$$$) { 18 | my ($x1, $y1, $x2, $y2) = @_; 19 | 20 | if ($METRIC eq 'euclidean') { 21 | return sqrt(($x1-$x2)**2 + ($y1-$y2)**2); 22 | } else { 23 | return (abs($x1-$x2) + abs($y1-$y2)); 24 | } 25 | } 26 | 27 | sub stddevp { 28 | my ($avg, $var, $stddev) = (0, 0, 0); 29 | local $_; 30 | 31 | for (@_) { 32 | $avg += $_; 33 | } 34 | $avg /= scalar(@_); 35 | 36 | for (@_) { 37 | $var += $_**2; 38 | } 39 | $var /= scalar(@_); 40 | 41 | # Reduce precision 42 | $var = sprintf('%f', $var); 43 | 44 | my $sq_avg = $avg**2; 45 | # Reduce precision again 46 | $sq_avg = sprintf('%f', $sq_avg); 47 | 48 | $var -= $sq_avg; 49 | 50 | $stddev = sqrt($var); 51 | return $stddev; 52 | } 53 | 54 | sub stddev { 55 | my ($avg, $var, $stddev) = (0, 0, 0); 56 | local $_; 57 | 58 | return 0 if (scalar(@_) == 1); 59 | 60 | for (@_) { 61 | $avg += $_; 62 | } 63 | $avg /= scalar(@_); 64 | 65 | for (@_) { 66 | $var += ($_-$avg)**2; 67 | } 68 | $var /= scalar(@_)-1; 69 | 70 | # Reduce precision 71 | $var = sprintf('%f', $var); 72 | 73 | $stddev = sqrt($var); 74 | return $stddev; 75 | } 76 | 77 | sub iquartile(@) { 78 | my @elems = @_; 79 | my $count = scalar(@elems); 80 | my ($lower, $upper) = ($count*0.25, $count*0.75); 81 | 82 | $lower = ceil($lower); 83 | $upper = ceil($upper); 84 | 85 | return @elems[($lower-1)..($upper-1)]; 86 | } 87 | 88 | 1; 89 | -------------------------------------------------------------------------------- /Mirror/RateLimiter.pm: -------------------------------------------------------------------------------- 1 | package Mirror::RateLimiter; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | 8 | sub load { 9 | my ($class, $storeref) = @_; 10 | my $self = {}; 11 | bless($self, $class); 12 | 13 | $self->{'store'} = $storeref; 14 | if (defined($$storeref)) { 15 | my @i = split (/:/, $$storeref, 3); 16 | $self->{'attempts'} = shift @i; 17 | $self->{'wait_til'} = shift @i; 18 | $self->{'increment'} = shift @i; 19 | $self->_initialize_run; 20 | } else { 21 | $self->_initialize; 22 | } 23 | 24 | return $self; 25 | } 26 | 27 | sub _initialize { 28 | my $self = shift; 29 | $self->{'attempts'} = 0; 30 | $self->{'wait_til'} = 3; 31 | $self->{'increment'} = 2; 32 | $self->_initialize_run; 33 | } 34 | 35 | sub _initialize_run { 36 | my $self = shift; 37 | $self->{'skip_tested'} = 0; 38 | $self->{'result'} = ''; 39 | } 40 | 41 | sub should_skip { 42 | my $self = shift; 43 | my $attempts = $self->{'attempts'}; 44 | $self->{'attempts'}++; 45 | 46 | $self->{'skip_tested'} = 1; 47 | 48 | return 0 if ($attempts <= 1); 49 | return 0 if ($self->{'wait_til'} == $attempts); 50 | 51 | $self->{'result'} = 'skip'; 52 | return 1; 53 | } 54 | 55 | sub record_failure { 56 | my $self = shift; 57 | 58 | croak "Forgot to check if you should_skip?" 59 | unless ($self->{'skip_tested'}); 60 | croak "Forgot to actually skip? or save?" 61 | if ($self->{'result'} && $self->{'result'} ne 'fail'); 62 | 63 | $self->{'result'} = 'fail'; 64 | 65 | if ($self->{'attempts'} <= 1) { 66 | $self->{'wait_til'} = 3; 67 | } elsif ($self->{'wait_til'} < $self->{'attempts'}) { 68 | $self->{'wait_til'} = $self->{'attempts'} + $self->{'increment'}; 69 | $self->{'increment'}++; 70 | } 71 | } 72 | 73 | sub attempts { 74 | my $self = shift; 75 | return $self->{'attempts'}; 76 | } 77 | 78 | sub save { 79 | my $self = shift; 80 | 81 | # If the state was not modified, there's nothing to save 82 | return unless ($self->{'skip_tested'}); 83 | 84 | # A non-declared result implies success 85 | if ($self->{'result'}) { 86 | $self->_initialize_run; 87 | } else { 88 | $self->_initialize; 89 | } 90 | $self->_save_state; 91 | } 92 | 93 | sub _save_state { 94 | my $self = shift; 95 | ${$self->{'store'}} = join(':', 96 | $self->{'attempts'}, 97 | $self->{'wait_til'}, 98 | $self->{'increment'}, 99 | ); 100 | } 101 | 102 | sub DESTROY { 103 | my $self = shift; 104 | $self->save; 105 | } 106 | 107 | 1; 108 | -------------------------------------------------------------------------------- /Mirror/Redirection/Blackhole.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Redirection::Blackhole; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | require Exporter; 7 | our @ISA = qw(Exporter); 8 | our @EXPORT = qw(should_blackhole); 9 | 10 | sub should_blackhole { 11 | my $url = shift; 12 | my $mirror_type = shift; 13 | 14 | if ($mirror_type eq 'archive') { 15 | return 1 if ($url =~ m,^dists/[^/]+/(?:main|contrib|non-free)/binary-[^/]+/Packages$,); 16 | return 1 if ($url =~ m,^dists/sid, && ( 17 | $url =~ m,/(?:main|contrib|non-free)/binary-[^/]+/Packages\.(?:lzma|bz2)$, || 18 | $url =~ m,/(?:main|contrib|non-free)/i18n/Translation[^/]+\.(?:lzma|gz)$, 19 | )); 20 | return 1 if ($url =~ m,^dists/jessie, && ( 21 | $url =~ m,/(?:main|contrib|non-free)/binary-[^/]+/Packages\.(?:lzma|bz2)$, || 22 | $url =~ m,/(?:main|contrib|non-free)/i18n/Translation[^/]+\.(?:lzma|gz)$, 23 | )); 24 | return 1 if ($url =~ m,^dists/wheezy, && ( 25 | $url =~ m,/(?:main|contrib|non-free)/binary-[^/]+/Packages\.(?:lzma|xz)$, || 26 | $url =~ m,/(?:main|contrib|non-free)/i18n/Translation[^/]+\.(?:lzma|xz|gz)$, 27 | )); 28 | return 1 if ($url =~ m,^dists/squeeze-updates/(?:main|contrib|non-free)/i18n/,); 29 | return 1 if ($url =~ m,^dists/squeeze-lts/(?:main|contrib|non-free)/binary-(?!i386|amd64),); 30 | return 1 if ($url =~ m,^dists/squeeze, && ( 31 | $url eq 'dists/squeeze/InRelease' || 32 | $url =~ m,/(?:main|contrib|non-free)/binary-[^/]+/Packages\.(?:lzma|xz)$, || 33 | $url =~ m,/(?:main|contrib|non-free)/i18n/Translation[^/]+\.(?:lzma|xz|gz)$, || 34 | $url =~ m,/(?:main|contrib|non-free)/i18n/Translation-en_(?:US|GB), 35 | )); 36 | return 1 if ($url =~ m,^dists/lenny,); 37 | } elsif ($mirror_type eq 'backports') { 38 | return 1 if ($url =~ m,^dists/squeeze-backports/(?:main|contrib|non-free)/i18n/, 39 | ); 40 | } elsif ($mirror_type eq 'security') { 41 | return 1 if ($url =~ m,^dists/[^/]+/updates/(?:main|contrib|non-free)/i18n/, 42 | ); 43 | } 44 | return 0; 45 | } 46 | 47 | 1; 48 | -------------------------------------------------------------------------------- /Mirror/Redirection/Permanent.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Redirection::Permanent; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | require Exporter; 7 | our @ISA = qw(Exporter); 8 | our @EXPORT = qw(is_permanent); 9 | 10 | sub is_permanent { 11 | my ($url, $type) = @_; 12 | return ($url =~ m,^pool/, || 13 | $url =~ m,\.diff/.+\.(?:gz|bz2|xz|lzma)$, || 14 | $url =~ m,/installer-[^/]+/\d[^/]+/, || 15 | $type eq 'old'); 16 | } 17 | 18 | 1; 19 | -------------------------------------------------------------------------------- /Mirror/Redirector.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Redirector; 2 | 3 | #################### 4 | # Copyright (C) 2011, 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Geo::IP; 27 | use Storable qw(retrieve); 28 | use Mirror::Math; 29 | use Mirror::AS; 30 | use Mirror::Redirection::Permanent; 31 | use Mirror::Redirection::Blackhole; 32 | use Mirror::Request; 33 | use URI::Escape qw(uri_escape); 34 | 35 | use Plack::Request; 36 | 37 | sub fullfils_request($$); 38 | sub print_xtra($$); 39 | sub clean_url($); 40 | sub consider_mirror($); 41 | sub url_for_mirror($); 42 | sub do_redirect($$); 43 | sub mirror_is_in_continent($$$); 44 | sub mirror_supports_ranges($$$); 45 | 46 | our %nearby_continents = ( 47 | 'AF' => [ qw(EU NA AS SA OC) ], 48 | 'SA' => [ qw(NA EU OC AS AF) ], 49 | 'OC' => [ qw(NA AS EU SA AF) ], 50 | 'AS' => [ qw(EU NA OC SA AF) ], 51 | 'NA' => [ qw(EU AS OC SA AF) ], 52 | 'EU' => [ qw(NA AS SA OC AF) ], 53 | ); 54 | 55 | our %nearby_country = ( 56 | 'NA' => [ qw(US CA) ], 57 | 'OC' => [ qw(AU NZ) ], 58 | ); 59 | 60 | our $metric = ''; # alt: taxicab (default) | euclidean 61 | our $stddev_set = 'iquartile'; # iquartile (default) | population 62 | our $random_sort = 1; 63 | our $db_store = 'db'; 64 | our $peers_db_store = 'db.peers'; 65 | our %this_host = map { $_ => 1 } qw(); # this host's hostname 66 | our $subrequest_method = ''; # alt: redirect (default) | sendfile | sendfile1.4 | accelredirect 67 | our $subrequest_prefix = 'serve/'; 68 | 69 | my ($_db, $db, $peers_db); 70 | my ($gdb4, $asdb4, $gdb6, $asdb6); 71 | 72 | sub new { 73 | my ($class) = @_; 74 | my $self = {}; 75 | bless($self, $class); 76 | 77 | # $_db holds the full database, while $db holds only the 78 | # part specific to the requested IP-family 79 | $db = $_db = retrieve($db_store); 80 | 81 | return $self; 82 | } 83 | 84 | sub get_ipdb { 85 | my ($ip, $ipv6) = @_; 86 | my $geo_rec; 87 | 88 | if (!$ipv6) { 89 | $gdb4 ||= Geo::IP->open('geoip/GeoLiteCity.dat', GEOIP_MMAP_CACHE); 90 | $geo_rec = $gdb4->record_by_addr($ip); 91 | } else { 92 | $gdb6 ||= Geo::IP->open('geoip/GeoLiteCityv6.dat', GEOIP_MMAP_CACHE); 93 | $geo_rec = $gdb6->record_by_addr_v6($ip); 94 | } 95 | return $geo_rec; 96 | } 97 | 98 | sub get_asdb { 99 | my ($ip, $ipv6) = @_; 100 | my $as; 101 | 102 | if (!$ipv6) { 103 | $asdb4 ||= Geo::IP->open('geoip/GeoIPASNum.dat', GEOIP_MMAP_CACHE); 104 | ($as) = split /\s+/, ($asdb4->org_by_addr($ip) || ' '); 105 | } else { 106 | my $asdb6 ||= Geo::IP->open('geoip/GeoIPASNumv6.dat', GEOIP_MMAP_CACHE); 107 | ($as) = split /\s+/, ($asdb6->org_by_addr_v6($ip) || ' '); 108 | } 109 | return $as; 110 | } 111 | 112 | sub run { 113 | my $self = shift; 114 | my $env = shift; 115 | my $req = Plack::Request->new($env); 116 | our $res = $req->new_response; 117 | 118 | my $request_method = $req->method || 'HEAD'; 119 | # abort POST and other requests ASAP 120 | if ($request_method ne 'GET' && $request_method ne 'HEAD') { 121 | $res->status(405); 122 | $res->header('Allow' => 'GET, HEAD'); 123 | return $res->finalize; 124 | } 125 | 126 | our $xtra_headers = 1; 127 | our $add_links = 1; 128 | our $mirror_type = 'archive'; 129 | our $permanent_redirect = 1; 130 | 131 | my @output; 132 | our @archs = (); 133 | my $action = 'redir'; 134 | 135 | if ($req->param('action') && $req->param('action') eq 'demo') { 136 | $action = 'demo'; 137 | } else { 138 | $xtra_headers = 0; 139 | $add_links = 0; 140 | } 141 | 142 | $mirror_type = $req->param('mirror') || 'archive'; 143 | 144 | if ($mirror_type =~ s/\.list$//) { 145 | $action = 'list'; 146 | $add_links = 0; 147 | 148 | @archs = $req->param('arch'); 149 | 150 | if (scalar(@archs) == 0) { 151 | $res->status(400); 152 | return $res->finalize; 153 | } 154 | } 155 | 156 | #### 157 | my $IP = $req->address; 158 | $IP = $self->get_local_ip($req) if ($IP eq '127.0.0.1' || !$IP); 159 | #### 160 | 161 | our $ipv6 = ($IP =~ m/:/); 162 | # Handle IPv6 over IPv4 requests as if they originated from an IPv4 163 | if ($ipv6 && $IP =~ m/^200(2|1(?=:0:)):/) { 164 | my $tunnel_type = $1; 165 | $ipv6 = 0; 166 | print_xtra('IPv6', $IP); 167 | 168 | if ($tunnel_type == 1) { # teredo 169 | $IP =~ m/:(\w{0,2}?)(\w{1,2}):(\w{0,2}?)(\w{1,2})$/ or die; 170 | $IP = join('.', hex($1)^0xff, hex($2)^0xff, hex($3)^0xff, hex($4)^0xff); 171 | } elsif ($tunnel_type == 2) { # 6to4 172 | $IP =~ m/^2002:(\w{0,2}?)(\w{1,2}):(\w{0,2}?)(\w{1,2}):/ or die; 173 | $IP = join('.', hex($1), hex($2), hex($3), hex($4)); 174 | } 175 | } 176 | 177 | $db = ($ipv6)? $_db->{'ipv6'} : $_db->{'ipv4'}; 178 | # Make a shortcut 179 | my $rdb = $db->{$mirror_type} or die("Invalid mirror type: $mirror_type"); 180 | 181 | my ($geo_rec, $as); 182 | our ($lat, $lon); 183 | 184 | $geo_rec = get_ipdb($IP, $ipv6); 185 | $as = get_asdb($IP, $ipv6); 186 | 187 | my $url = clean_url($req->param('url') || ''); 188 | 189 | if (should_blackhole($url, $mirror_type)) { 190 | $res->status(404); 191 | return $res->finalize; 192 | } 193 | 194 | if (!defined($geo_rec)) { 195 | require Mirror::FallbackGeoLocation; 196 | $geo_rec = Mirror::FallbackGeoLocation::get_record($db, $mirror_type); 197 | } 198 | # this should be a no-op now: 199 | if (!defined($geo_rec)) { 200 | # request can be handled locally. So, do it 201 | if ($action eq 'redir' && scalar(keys %this_host)) { 202 | do_redirect('', $url); 203 | return $res->finalize; 204 | } 205 | # sadly, we really depend on it. throw an error for now 206 | $res->status(501); 207 | return $res->finalize; 208 | } 209 | $as = Mirror::AS::convert($as); 210 | 211 | $lat = $geo_rec->latitude; 212 | $lon = $geo_rec->longitude; 213 | 214 | # Do not send Link headers on directory requests 215 | $add_links = 0 if ($add_links && $url =~ m,/$,); 216 | 217 | @archs or @archs = Mirror::Request::get_arch($url); 218 | # @archs may only have more than one element iff $action eq 'list' 219 | # 'all' is not part of the archs that may be passed when running under 220 | # $action eq 'list', so it should be safe to assume the size of the 221 | # array 222 | $archs[0] = '' if ($archs[0] eq 'all'); 223 | 224 | # If no mirror provides the 'source' "architecture" assume it is 225 | # included by all mirrors. Apply the restriction otherwise. 226 | if ($archs[0] eq 'source' && !exists($rdb->{'arch'}{'source'})) { 227 | $archs[0] = ''; 228 | } 229 | 230 | # Do not use .=, as it would be concatenating to the 231 | # scoped "my" variable rather than to the global variable 232 | my $peers_db_store = $peers_db_store.'-'.$db->{'id'} 233 | if (exists($db->{'id'}) && $peers_db_store); 234 | 235 | our ($require_inrelease, $require_i18n) = (0, 0); 236 | if ($mirror_type ne 'old') { 237 | $require_inrelease = ($url =~ m,/InRelease$,); 238 | $require_i18n = ($url =~ m,^dists/.+/i18n/,); 239 | } 240 | 241 | if ($permanent_redirect) { 242 | $permanent_redirect = is_permanent($url, $mirror_type); 243 | } 244 | 245 | Mirror::Math::set_metric($metric); 246 | 247 | my $continent = $geo_rec->continent_code; 248 | $continent = 'EU' if ($continent eq '--'); 249 | 250 | print_xtra('IP', $IP); 251 | print_xtra('AS', $as); 252 | print_xtra('URL', $url); 253 | print_xtra('Arch', join(', ', @archs)); 254 | print_xtra('Country', $geo_rec->country_code); 255 | print_xtra('Continent', $continent); 256 | print_xtra('City', $geo_rec->city); 257 | print_xtra('Region', $geo_rec->region || ''); 258 | 259 | our %hosts = (); 260 | my $match_type = ''; 261 | 262 | # match by AS 263 | foreach my $match (@{$rdb->{'AS'}{$as}}) { 264 | next unless (mirror_is_in_continent($rdb, $match, $continent)); 265 | 266 | $match_type = 'AS' if (consider_mirror ($match)); 267 | } 268 | 269 | # match by AS peer 270 | if (!$match_type && $as && !$ipv6 && (defined($peers_db) || ($peers_db_store && -f $peers_db_store))) { 271 | $peers_db ||= retrieve($peers_db_store); 272 | 273 | foreach my $match (keys %{$peers_db->{$as}}) { 274 | next unless (exists($db->{'all'}{$match}{$mirror_type.'-http'})); 275 | next unless (mirror_is_in_continent($rdb, $match, $continent)); 276 | 277 | $match_type = 'AS-peer' if (consider_mirror ($match)); 278 | } 279 | } 280 | 281 | # match by country 282 | if (!$match_type) { 283 | foreach my $match (keys %{$rdb->{'country'}{$geo_rec->country_code}}) { 284 | $match_type = 'country' if (consider_mirror ($match)); 285 | } 286 | } 287 | 288 | # match by nearby-country 289 | if (!$match_type && exists($nearby_country{$continent})) { 290 | for my $country (@{$nearby_country{$continent}}) { 291 | foreach my $match (keys %{$rdb->{'country'}{$country}}) { 292 | $match_type = 'nearby-country' if (consider_mirror ($match)); 293 | } 294 | } 295 | } 296 | 297 | # match by continent 298 | if (!$match_type) { 299 | my @continents = ($continent, @{$nearby_continents{$continent}}); 300 | 301 | for my $mirror_continent (@continents) { 302 | last if ($match_type); 303 | 304 | my $mtype; 305 | if ($mirror_continent eq $continent) { 306 | $mtype = 'continent'; 307 | } else { 308 | $mtype = 'nearby-continent'; 309 | } 310 | 311 | foreach my $match (keys %{$rdb->{'continent'}{$mirror_continent}}) { 312 | $match_type = $mtype if (consider_mirror ($match)); 313 | } 314 | } 315 | } 316 | 317 | # something went awry, we don't know how to handle this user, we failed 318 | if (!$match_type) { 319 | $res->status(503); 320 | return $res->finalize; 321 | } 322 | 323 | 324 | my @sorted_hosts = sort { $hosts{$a} <=> $hosts{$b} } keys %hosts; 325 | my @close_hosts; 326 | my $dev; 327 | 328 | if ($stddev_set eq 'population') { 329 | $dev = Mirror::Math::stddevp(values %hosts); 330 | } else { 331 | my @iq_dists = map { $hosts{$_} } Mirror::Math::iquartile(@sorted_hosts); 332 | $dev = Mirror::Math::stddev(@iq_dists); 333 | } 334 | 335 | # Closest host (or one of many), to use as the base distance 336 | my $host = $sorted_hosts[0]; 337 | 338 | print_xtra('Std-Dev', $dev); 339 | print_xtra('Population', scalar(@sorted_hosts)); 340 | print_xtra('Closest-Distance', $hosts{$host}); 341 | 342 | for my $h (@sorted_hosts) { 343 | # NOTE: this might need some additional work, as we should probably 344 | # guarantee a certain amount of alt hosts to choose from 345 | if (($hosts{$h} - $hosts{$host}) <= $dev && 346 | (scalar(@close_hosts) < 4 || $hosts{$h} == $hosts{$close_hosts[-1]})) { 347 | push @close_hosts, $h; 348 | } else { 349 | # the list is sorted, if we didn't accept this one won't accept 350 | # the next 351 | last; 352 | } 353 | } 354 | 355 | if (defined($req->header('Range')) && scalar(@close_hosts) > 1) { 356 | my @favorable_hosts; 357 | for my $id (@close_hosts) { 358 | push @favorable_hosts, $id 359 | if (mirror_supports_ranges($db, $id, $mirror_type)); 360 | } 361 | if (scalar(@favorable_hosts)) { 362 | @close_hosts = @favorable_hosts; 363 | } 364 | } 365 | 366 | if ($random_sort) { 367 | my $n = int(rand scalar(@close_hosts)); 368 | $host = $close_hosts[$n]; 369 | } 370 | print_xtra('Distance', $hosts{$host}); 371 | print_xtra('Match-Type', $match_type); 372 | 373 | if ($action eq 'redir') { 374 | do_redirect($host, $url); 375 | } elsif ($action eq 'demo') { 376 | $res->status(200); 377 | $res->header('Cache-control', 'no-cache'); 378 | $res->header('Pragma', 'no-cache'); 379 | } elsif ($action eq 'list') { 380 | $res->status(200); 381 | $res->content_type('text/plain'); 382 | for my $host (@close_hosts) { 383 | push @output, url_for_mirror($host)."\n"; 384 | } 385 | } else { 386 | die("FIXME: unknown action '$action'"); 387 | } 388 | 389 | if ($add_links && (scalar(@close_hosts) > 1 || $action eq 'demo')) { 390 | # RFC6249-like link rels 391 | # A client strictly adhering to the RFC would ignore these since we 392 | # don't provide a digest, and we wont. 393 | my @link_headers; 394 | for my $host (@close_hosts) { 395 | my $depth = 0; 396 | my $priority = $hosts{$host}; 397 | 398 | $priority *= 100; 399 | $priority = 1 if ($priority == 0); 400 | $priority = sprintf("%.0f", $priority); 401 | 402 | if ($url =~ m,^dists/[^/]+/(?:main|contrib|non-free)/Contents-[^.]+\.diff(/.*)$, || 403 | $url =~ m,^dists/[^/]+/(?:main|contrib|non-free)/binary-[^/]+(/.*)$, || 404 | $url =~ m,^dists/[^/]+/(?:main|contrib|non-free)/i18n(/.*)$, || 405 | $url =~ m,^project(/.*)$, || 406 | $url =~ m,^tools(/.*)$,) { 407 | $depth = $1 =~ tr[/][/]; 408 | } 409 | 410 | push @link_headers, "<".url_for_mirror($host).$url.">; rel=duplicate; pri=$priority; depth=$depth"; 411 | } 412 | my $link_header = join(', ', @link_headers); 413 | if ($action ne 'demo') { 414 | # Pre-wheezy versions of APT break on header lines of >= 360 415 | # bytes, so ensure we don't exceed that limit. This can be 416 | # safely removed if/when those versions are not/no longer 417 | # supported 418 | while (length($link_header) >= (360-length("Link: \n"))) { 419 | pop @link_headers; 420 | $link_header = join(', ', @link_headers); 421 | } 422 | } 423 | $res->header('Link' => $link_header); 424 | } 425 | 426 | $res->body(\@output); 427 | return $res->finalize; 428 | 429 | sub fullfils_request($$) { 430 | my ($rdb, $id) = @_; 431 | 432 | my $mirror = $db->{'all'}{$id}; 433 | 434 | return 0 if (exists($mirror->{$mirror_type.'-disabled'})); 435 | 436 | return 0 if ($require_inrelease && exists($mirror->{$mirror_type.'-notinrelease'})); 437 | 438 | return 0 if ($require_i18n && exists($mirror->{$mirror_type.'-noti18n'})); 439 | 440 | for my $arch (@archs) { 441 | next if ($arch eq ''); 442 | 443 | return 0 if (!exists($rdb->{'arch'}{$arch}{$id}) && !exists($rdb->{'arch'}{'any'}{$id})); 444 | 445 | return 0 if (exists($mirror->{$mirror_type.'-'.$arch.'-disabled'})); 446 | } 447 | 448 | return 1; 449 | } 450 | 451 | sub print_xtra($$) { 452 | $res->header("X-$_[0]", $_[1]) 453 | if ($xtra_headers); 454 | } 455 | 456 | sub consider_mirror($) { 457 | my ($id) = @_; 458 | 459 | my $mirror = $db->{'all'}{$id}; 460 | 461 | return 0 unless fullfils_request($db->{$mirror_type}, $id); 462 | 463 | $hosts{$id} = Mirror::Math::calculate_distance($mirror->{'lon'}, $mirror->{'lat'}, 464 | $lon, $lat); 465 | return 1; 466 | } 467 | 468 | 469 | sub url_for_mirror($) { 470 | my $id = shift; 471 | return '' unless (length($id)); 472 | my $mirror = $db->{'all'}{$id}; 473 | return "http://".$mirror->{'site'}.$mirror->{$mirror_type.'-http'}; 474 | } 475 | 476 | sub do_redirect($$) { 477 | my ($host, $real_url) = @_; 478 | 479 | if (scalar(keys %this_host)) { 480 | if ($host eq '' || exists($this_host{$db->{'all'}{$host}{'site'}})) { 481 | my $internal_subreq = 0; 482 | $real_url = $subrequest_prefix.$real_url; 483 | 484 | if ($subrequest_method eq 'sendfile') { 485 | $res->header('X-Sendfile', $real_url); 486 | $internal_subreq = 1; 487 | } elsif ($subrequest_method eq 'sendfile1.4') { 488 | $res->header('X-LIGHTTPD-send-file', $real_url); 489 | $internal_subreq = 1; 490 | } elsif ($subrequest_method eq 'accelredirect') { 491 | $res->header('X-Accel-Redirect', $real_url); 492 | $internal_subreq = 1; 493 | } else { 494 | # do nothing special, will redirect 495 | } 496 | 497 | if ($internal_subreq) { 498 | $res->header('Content-Location', $real_url); 499 | return; 500 | } 501 | } 502 | } 503 | 504 | $res->content_type('text/plain'); 505 | my $rcode; 506 | if ($permanent_redirect) { 507 | $rcode = 301; 508 | } else { 509 | $rcode = 302; 510 | } 511 | $res->redirect(url_for_mirror($host).$real_url, $rcode); 512 | return; 513 | } 514 | 515 | } 516 | 517 | sub clean_url($) { 518 | my $url = shift; 519 | $url =~ s,//,/,g; 520 | $url =~ s,^/,,; 521 | $url =~ s,^\.\.?/,,g; 522 | $url =~ s,(?<=/)\.\.?(?:/|$),,g; 523 | $url = uri_escape($url); 524 | $url =~ s,%2F,/,g; 525 | $url =~ s,%20,+,g; 526 | return $url; 527 | } 528 | 529 | sub mirror_is_in_continent($$$) { 530 | my ($rdb, $id, $continent) = @_; 531 | 532 | return (exists($rdb->{'continent'}{$continent}{$id})); 533 | } 534 | 535 | sub mirror_supports_ranges($$$) { 536 | my ($db, $id, $type) = @_; 537 | 538 | return (exists($db->{'all'}{$id}{$type.'-ranges'})); 539 | } 540 | 541 | sub set_local_ip { 542 | my $self = shift; 543 | my $translation = shift; 544 | 545 | if (ref $translation ne 'CODE') { 546 | my $ip = $translation; 547 | $translation = sub { return $ip; }; 548 | } 549 | 550 | $self->{'local_ip'} = $translation; 551 | return; 552 | } 553 | 554 | sub get_local_ip { 555 | my $self = shift; 556 | my $req = shift; 557 | 558 | if (defined($self->{'local_ip'})) { 559 | return $self->{'local_ip'}($req); 560 | } else { 561 | return $self->_query_remote_ip; 562 | } 563 | } 564 | 565 | sub _query_remote_ip { 566 | my $self = shift; 567 | my $ip; 568 | 569 | if (defined($ENV{'HARNESS_ACTIVE'})) { 570 | $ip = '4.4.4.4'; 571 | } else { 572 | $ip = `wget -O- -q http://myip.dnsomatic.com/`; 573 | } 574 | 575 | $self->set_local_ip($ip) if ($ip); 576 | return $ip; 577 | } 578 | 579 | 1; 580 | -------------------------------------------------------------------------------- /Mirror/Request.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Request; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Even-numbered list: '[default]' => qr/regex/ 7 | # Whenever regex matches but there's no value in the capture #1 then 8 | # the default value is used. 9 | our @ARCHITECTURES_REGEX = ( 10 | '' => qr'^dists/(?:[^/]+/){2,3}binary-([^/]+)/', 11 | '' => qr'^pool/(?:[^/]+/){3,4}.+_([^.]+)\.u?deb$', 12 | '' => qr'^dists/(?:[^/]+/){1,2}Contents-(?:udeb-(?!nf))?(?!udeb)([^.]+)\.(?:gz$|diff/)', 13 | '' => qr'^indices/files(?:/components)?/arch-([^.]+).*$', 14 | '' => qr'^dists/(?:[^/]+/){2}installer-([^/]+)/', 15 | '' => qr'^dists/(?:[^/]+/){2,3}(source)/', 16 | 'source' => qr'^pool/(?:[^/]+/){3,4}.+\.(?:dsc|(?:diff|tar)\.(?:xz|gz|bz2))$', 17 | ); 18 | 19 | sub get_arch { 20 | my $url = shift; 21 | 22 | my $i = 0; 23 | while ($i + 1 < scalar(@ARCHITECTURES_REGEX)) { 24 | my ($default, $rx) = @ARCHITECTURES_REGEX[$i++ .. $i++]; 25 | 26 | if ($url =~ m/$rx/) { 27 | my $arch = $1 || $default; 28 | return $arch; 29 | } 30 | } 31 | return ''; 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /Mirror/Trace.pm: -------------------------------------------------------------------------------- 1 | package Mirror::Trace; 2 | 3 | use strict; 4 | use warnings; 5 | use Date::Parse; 6 | 7 | use vars qw($MIN_FTPSYNC_VERSION $MIN_DMSSYNC_VERSION); 8 | 9 | sub new { 10 | my ($class, $base_url) = @_; 11 | my $self = {}; 12 | bless($self, $class); 13 | 14 | $MIN_FTPSYNC_VERSION = 80387; 15 | $MIN_DMSSYNC_VERSION = '0.1'; 16 | 17 | $self->{'base_url'} = $base_url if (defined($base_url)); 18 | 19 | return $self; 20 | } 21 | 22 | sub get_url { 23 | my $self = shift; 24 | my $file = shift; 25 | 26 | return $self->{'base_url'}.'project/trace/'.$file; 27 | } 28 | 29 | sub from_string { 30 | my $self = shift; 31 | my $trace = shift; 32 | 33 | my ($date, $software, $archs, $revisions); 34 | 35 | my @trace_lines = split /\n/,$trace; 36 | ($date, $software) = (shift @trace_lines, shift @trace_lines); 37 | 38 | return 0 unless (defined($date)); 39 | 40 | return 0 41 | unless ($date =~ m/^\w{3} \s+ \w{3} \s+ \d{1,2} \s+ (?:\d{2}:){2}\d{2} \s+ (?:UTC|GMT) \s+ \d{4}$/x); 42 | 43 | # feed-back the second line in case it can be parsed as a header:value string 44 | unshift @trace_lines, $software 45 | if (defined($software) && $software =~ m/:/); 46 | 47 | for my $line (@trace_lines) { 48 | return 0 unless ($line =~ m/^([\w -]+):(.*)\s*$/); 49 | my ($key, $val) = ($1, $2); 50 | 51 | $archs = $val if ($key eq 'Architectures'); 52 | $revisions = $val if ($key eq 'Revision'); 53 | $software = $line if ($key eq 'Used ftpsync version'); 54 | } 55 | 56 | if (defined($revisions)) { 57 | my @revs = split /\s+/,$revisions; 58 | $revisions = { map { lc($_) => 1 } @revs }; 59 | } 60 | 61 | $self->{'software'} = $software || ''; 62 | $self->{'date'} = str2time($date) or return 0; 63 | $self->{'archs'} = $archs; 64 | $self->{'revision'} = $revisions; 65 | 66 | return 1; 67 | } 68 | 69 | sub date { 70 | my $self = shift; 71 | return $self->{'date'}; 72 | } 73 | 74 | sub uses_ftpsync { 75 | my $self = shift; 76 | 77 | return 1 78 | if ($self->{'software'} =~ m/^Used ftpsync(?: version|-pushrsync from): /); 79 | return 1 80 | if ($self->{'software'} =~ m/^DMS sync dms-/); 81 | return 0; 82 | } 83 | 84 | sub good_ftpsync { 85 | my $self = shift; 86 | 87 | return 1 88 | if ($self->{'software'} =~ m/^Used ftpsync-pushrsync/); 89 | 90 | if ($self->{'software'} =~ m/^Used ftpsync version: ([0-9]+)$/) { 91 | return ($1 >= $MIN_FTPSYNC_VERSION && $1 ne 80486); 92 | } 93 | if ($self->{'software'} =~ m/^DMS sync dms-([0-9.\w-]+)$/) { 94 | return ($1 ge $MIN_DMSSYNC_VERSION); 95 | } 96 | 97 | return 0; 98 | } 99 | 100 | sub features { 101 | my $self = shift; 102 | my $feature = shift; 103 | 104 | if ($feature eq 'architectures') { 105 | return defined($self->{'archs'}); 106 | } 107 | 108 | return 1 109 | if ($feature eq 'revision' && defined($self->{'revision'})); 110 | if (defined($self->{'revision'})) { 111 | return (exists($self->{'revision'}{$feature})); 112 | } 113 | 114 | return 1 115 | if ($self->{'software'} =~ m/^Used ftpsync-pushrsync/); 116 | 117 | if ($self->{'software'} =~ m/^Used ftpsync version: ([0-9]+)$/) { 118 | my $version = $1; 119 | return 1 if ($feature eq 'inrelease' && $version >= 80387); 120 | return 1 if ($feature eq 'i18n' && $version >= 20120521); 121 | return 1 if ($feature eq 'auip' && $version >= 20130501); 122 | } 123 | if ($self->{'software'} =~ m/^DMS sync dms-([0-9.\w-]+)$/) { 124 | my $version = $1; 125 | return 1 if ($feature eq 'inrelease' && $version ge '0.1'); 126 | return 1 if ($feature eq 'i18n' && $version ge '0.2'); 127 | } 128 | 129 | return 0; 130 | } 131 | 132 | sub arch { 133 | my $self = shift; 134 | my $arch = shift; 135 | 136 | return ($self->{'archs'} =~ m/\b$arch\b/ || $self->{'archs'} =~ m/\bFULL\b/); 137 | } 138 | 139 | 1; 140 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Intro 2 | ===== 3 | 4 | This is a work in progress. Please do send patches and provide feedback. 5 | Thanks! 6 | 7 | The project is similar to mirrorbrain (.org) and fedora's mirrors 8 | system. However, it has a few differences (this list is not intended to 9 | be complete): 10 | 11 | * it is very specific to the way Debian mirrors are constructed. 12 | Details regarding architectures and the different mirror types are 13 | taken into consideration. 14 | * because of the previous point and considering many mirrors only 15 | support http, it does not perform a full mirror scan. Mirrorbrain does. 16 | There's a tool to detect inconsistencies between what the mirrors master 17 | list claims a mirror contains and what it actually contains. 18 | * it aims to be httpd-independent. Mirrorbrain requires apache. 19 | * IPv6 support 20 | * no DBMS. Although using a DBMS could provide some advantages, at the 21 | moment the Storable database seems to be enough. The idea is to keep 22 | everything simple. 23 | * easy deployment 24 | 25 | Live instance 26 | ============= 27 | 28 | There's a live instance of this code (but not necessarily the latest 29 | and greatest revision) at http://httpredir.debian.org/ (previously, 30 | http.debian.net) 31 | 32 | There's some more documentation there. It should be imported into the 33 | repository, however. 34 | 35 | TODO 36 | ==== 37 | 38 | There are some TODOs and FIXMEs in the source code, additionally, 39 | there's the issues tracker at github: 40 | https://github.com/rgeissert/http-redirector/issues 41 | 42 | Getting started 43 | =============== 44 | 45 | Required packages: 46 | * `moreutils` 47 | * `libanyevent-perl` 48 | * `libanyevent-http-perl` 49 | * `libev-perl` (recommended; or another event loop supported by AE) 50 | * `libtimedate-perl` 51 | * `libgeo-ip-perl` 52 | * `libwww-perl` 53 | * `liburi-perl` 54 | * `libplack-perl` 55 | * `liblinux-inotify2-perl` (for plackup -R, for local tests only) 56 | * `starman` (if using that server for the application) 57 | * `twiggy` (alternative server) 58 | * `wget` 59 | 60 | Run `./update.sh`, it will download the geoip databases, the mirrors 61 | list, build the database used by the redirector, and check the mirrors 62 | for errors. 63 | 64 | Look at the example below for invocation and plackup(1p) and Plack's 65 | documentation for running the application under different server modes. 66 | 67 | If you just want to simulate a request (like it used to be possible 68 | with `redir.pl`), use `local-request.pl`. It sends a request to the 69 | application without actually starting the server. 70 | You can pass request parameters in the first argument to the script. 71 | To fake the IP address of the request, set the `REMOTE_ADDR` env var when 72 | calling it. No other CGI-like env var is recognised. 73 | 74 | Getting started for development 75 | =============================== 76 | 77 | Required packages (in addition to the ones above): 78 | * `libtest-trap-perl` 79 | 80 | Keeping everything in shape 81 | =========================== 82 | 83 | update.sh should be run at least once a month[1], this allows the 84 | changes to the mirror list(s) to be reflected. By default it will run: 85 | - `build-main-db.pl` 86 | - `build-peers-db.pl` 87 | - `check.pl` 88 | 89 | `check.pl` should be run multiple times a day[2] 90 | 91 | `build-peers-db.pl` should be run after every execution of 92 | `build-main-db.pl` or whenever the peers lists are updated[3] 93 | 94 | NOTE: update.sh will leave the new database in a file called `db.in` 95 | to be renamed to `db` if it is the first time it is created. When 96 | updating the db of an in-production instance, the new db will be picked up 97 | by the next run of `check.pl`. 98 | 99 | NOTE: `build-main-db.pl` and `check.pl` do NOT lock the database. You must 100 | ensure that no more than one script is running at the same time. 101 | 102 | [1] the script rebuilds the database, so any info collected by check.pl 103 | regarding the availability of mirrors is lost. 104 | check.pl --check-everything should be run after build-main-db.pl, this is 105 | done automatically when running update.sh. 106 | 107 | [2] it really depends on the kind of setup one wants and the hosts that 108 | conform the mirrors network. For Debian's archive, it should be run 109 | at least every ten minutes, every five minutes being better. 110 | 111 | [3] it only applies when using an AS peers database. The name of the 112 | peers database is specific to the mirrors database on which it is 113 | based. At present, peers databases for old mirrors databases are not 114 | cleaned up automatically. 115 | 116 | Real life testing 117 | ================= 118 | 119 | If using apache, you will want to run the redirector locally and make 120 | apache forward the requests (therefore acting as a reverse proxy). 121 | For example, if you run the application on port 5000 you can: 122 | 123 | ```apache 124 | ProxyPass /redir http://127.0.0.1:5000/ 125 | 126 | RewriteEngine On 127 | RewriteRule ^/?(?:(demo)/)?debian-(security|backports|ports)/(.*) /redir/?mirror=$2&url=$3&action=$1 [PT] 128 | RewriteRule ^/?(?:(demo)/)?debian-archive/(.*) /redir/?mirror=old&url=$2&action=$1 [PT] 129 | RewriteRule ^/?(?:(demo)/)?debian/(.*) /redir/?mirror=archive&url=$2&action=$1 [PT] 130 | 131 | # mirror:// method support: 132 | RewriteRule ^/?debian-(security|backports|ports)\.list(?:$|\?(.+)) /redir/?mirror=$1.list$2 [QSA,PT] 133 | RewriteRule ^/?debian-archive\.list(?:$|\?(.+)) /redir/?mirror=old.list$1 [QSA,PT] 134 | RewriteRule ^/?debian\.list(?:$|\?(.+)) /redir/?mirror=archive.list$1 [QSA,PT] 135 | ``` 136 | 137 | You can for example make it listen on 127.0.1.10, setup a vhost, and 138 | use the following on your sources.list: 139 | 140 | ```sources.list 141 | deb http://127.0.1.10/debian/ sid main 142 | deb-src http://127.0.1.10/debian/ sid main 143 | 144 | deb http://127.0.1.10/debian-security/ testing/updates main 145 | deb http://security.debian.org/ testing/updates main 146 | ``` 147 | 148 | Note: accessing the redirector from a local IP address is not ideal and 149 | may only work with hacks. 150 | 151 | Forcibly disabling mirrors 152 | ========================== 153 | 154 | If necessary, mirrors can forcibly be disabled by passing a file name 155 | to `check.pl`'s `--disable-sites` option (`default: sites.disabled`) 156 | 157 | The format of this file is: 158 | 159 | ``` 160 | [/mirror type] 161 | ``` 162 | 163 | Whenever the option is passed and the file exists, every mirror 164 | matching an entry in the file will be disabled without further checks. 165 | If a mirror type is specified, only that mirror type of the given 166 | mirror will be disabled. 167 | 168 | An empty file name can be specified to override the default and to 169 | prevent the parsing of said file. In order to re-enable a mirror an 170 | existing file name must be specified. 171 | 172 | NOTE: any disabled mirror that is no longer in the list will be 173 | re-enabled. E.g. passing `--disable-sites /dev/null` to `check.pl` will 174 | re-enable *all* disabled mirrors. 175 | 176 | Running the redirector on top of a real mirror 177 | ============================================== 178 | 179 | It is possible to run the redirector on a sever that has the files 180 | itself. The use case would be: serve some users, send others to a 181 | better mirror. 182 | 183 | In order to use it in this mode, a few things need to be setup. 184 | 185 | Mirror::Redirector: 186 | * Set the `subrequest_method` variable as appropriate: 187 | - redirect: works on any httpd, but requires another roundtrip 188 | - sendfile: for apache with mod_xsendfile, lighttpd 1.5, cherokee 189 | - sendfile1.4: for lighttpd 1.4 190 | - accelredirect: for nginx 191 | * Set the list of hosts for which the files will be served, in the 192 | `this_host` variable. 193 | For example, if your host is `my.mirror.tld`, that's what you need to 194 | add. 195 | 196 | NOTE: even though it is possible to list other mirror's host names, 197 | care should be taken when doing so. The mirror checker is not aware of 198 | this mapping and may lead to erroneous behaviour. 199 | 200 | NOTE2: make sure your httpd works as expected. The redirector sends a 201 | Content-Location header when the file should be delivered by the server 202 | itself. Make sure it is not removed. Also look for issues with Range, 203 | Last-Modified, and other features. 204 | 205 | Then, setup your httpd so that requests for serve/ are served directly, 206 | bypassing the redirector. 207 | Finally, make all the usual traffic go through the redirector. Make 208 | sure you don't break directory listing when doing so. mod_xsendfile, 209 | for example, breaks it because it bypasses mod_autoindex. 210 | 211 | A sample configuration for apache follows: 212 | 213 | ```apache 214 | XSendFile On 215 | 216 | # Should be possible to do it without an alias, but it makes it a 217 | # bit clearer 218 | Alias /debian/serve/ "/var/www/debian/" 219 | 220 | RewriteEngine On 221 | # Exclude /debian/serve/ from mod_rewrite, mod_alias will handle it 222 | RewriteRule ^/?debian/serve/.*$ $0 [PT,L] 223 | # Send all file requests through the redirector 224 | RewriteRule ^/?debian/(.*[^/]$) /redir/?mirror=archive&url=$1 [NS,PT] 225 | # Directory listing requests will pass-through and be handled by 226 | # apache itself 227 | ``` 228 | 229 | IMPORTANT: do not enable this setup, or run the redirector at all, on a 230 | mirror that is part of Debian's mirrors network without consulting the 231 | mirroradmin group and WAITING for their APPROVAL. 232 | 233 | AS peers database 234 | ================= 235 | 236 | It is possible to instruct the redirector to serve clients from an 237 | originating AS to one or a set of destination AS' where mirrors are 238 | located. The database can be built with the build-peers-db.pl script. 239 | 240 | Its input are \*.lst files in the peers.lst.d directory in the following 241 | format: 242 | 243 | ``` 244 | [distance [IPv]] 245 | ``` 246 | 247 | The preferred form of the second value is by domain name. When an AS is 248 | specified, it will internally be rewritten to the existing mirrors in 249 | the corresponding AS. 250 | 251 | Comments may be specified by prefixing them with a `#` character. 252 | Multiple client ASNs can be specified by enclosing them in braces and 253 | separating them with commas. E.g. `{13138,2210} some.mirror.tld` 254 | 255 | The distance is currently not used by the redirector, but at some point 256 | it might. It defaults to 0. Any positive integer may be specified. 257 | It is expected to be read as 0 being the most preferred mirror, 1 being 258 | the second, 2 being the third, and so on. 259 | 260 | The IPv field, if specified, should be `v4`, `v6`, or the two separated 261 | by a comma with no specific order. It can be used to indicate that the 262 | given peering rule only applies to the version of the IP specified in 263 | the field. It defaults to `v4`. 264 | 265 | Mirrors chosen by this database are still subject to geo location 266 | restriction. I.e. from the set of candidates, a subset of those that 267 | are geographically closer will be created and used. 268 | 269 | Caveats: since the database is AS-based, large Autonomous Systems that 270 | traverse countries or continents will still be considered, even if not 271 | desired. At present, the redirector skips mirrors that are located in a 272 | different continent, but that's done to work around another issue and 273 | the behaviour is not guaranteed to persist after the other issue is 274 | properly addressed. 275 | 276 | Understanding the db 277 | ==================== 278 | 279 | The database consists of (mostly inverted) indexes that are supposed to 280 | provide fast and cheap lookups. 281 | 282 | In order to save space on the database, a few unusual things are done. 283 | For example, hash entries with `undef` as value are valid. `undef` is 284 | smaller in a Storable database than an integer. 285 | Any script using the database should therefore test for 'exists' instead 286 | of 'defined'. 287 | 288 | To better understand what the database looks like, run ./dump-db.pl | pager 289 | 290 | Credits 291 | ======= 292 | 293 | "This product includes GeoLite data created by MaxMind, available from 294 | http://maxmind.com/" 295 | -------------------------------------------------------------------------------- /app-proxy.psgi: -------------------------------------------------------------------------------- 1 | # -*- perl -*- 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use lib '.'; 7 | use Mirror::Redirector; 8 | 9 | my $app = Mirror::Redirector->new; 10 | $app->set_local_ip(sub { 11 | my $req = shift; 12 | my $ip = '8.8.8.8'; 13 | if ($req->header('x-forwarded-for')) { 14 | $ip = (split(/\s*,\s*/, $req->header('x-forwarded-for')))[-1]; 15 | } 16 | return $ip; 17 | }); 18 | sub { $app->run(@_); } 19 | -------------------------------------------------------------------------------- /app.psgi: -------------------------------------------------------------------------------- 1 | # -*- perl -*- 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use lib '.'; 7 | use Mirror::Redirector; 8 | 9 | my $app = Mirror::Redirector->new; 10 | sub { $app->run(@_); } 11 | -------------------------------------------------------------------------------- /build-main-db.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | #################### 4 | # Copyright (C) 2011 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | use Getopt::Long; 26 | use Socket; 27 | use Geo::IP; 28 | use Storable qw(dclone); 29 | 30 | use Mirror::AS; 31 | use Mirror::DB; 32 | 33 | use AE; 34 | use AnyEvent::DNS; 35 | 36 | my $input_dir = 'mirrors.lst.d'; 37 | my $db_store = 'db'; 38 | my $db_output = $db_store; 39 | my @mirror_types = qw(www volatile archive old nonus 40 | backports security cdimage ports); 41 | my %exclude_mirror_types = map { $_ => 1 } qw(nonus www volatile cdimage); 42 | 43 | # Options: 44 | my ($update_list, $threads) = (0, -1); 45 | our $verbose = 0; 46 | 47 | sub get_lists($); 48 | sub parse_list($$); 49 | sub process_entry4($@); 50 | sub process_entry6($@); 51 | sub process_entry_common($$$$$@); 52 | sub query_dns_for_entry($); 53 | sub bandwidth_to_mb($); 54 | 55 | GetOptions('update-list!' => \$update_list, 56 | 'list-directory=s' => \$input_dir, 57 | 'j|threads=i' => \$threads, 58 | 'db-output=s' => \$db_output, 59 | 'verbose' => \$verbose) or exit 1; 60 | 61 | if ($update_list) { 62 | die("error: use update.sh to fetch/update the mirrors list\n"); 63 | } 64 | 65 | my %all_sites; 66 | my @data; 67 | my @input_files; 68 | 69 | @input_files = get_lists($input_dir); 70 | 71 | for my $list (sort @input_files) { 72 | @data = (@data, parse_list($list, \%all_sites)); 73 | } 74 | 75 | my $cv = AE::cv; 76 | my %full_db = ('ipv4' => {}, 'ipv6' => {}); 77 | my $db4 = $full_db{'ipv4'}; 78 | my $db6 = $full_db{'ipv6'}; 79 | my $i = 0; 80 | 81 | foreach my $mirror_type (@mirror_types) { 82 | next if ($exclude_mirror_types{$mirror_type}); 83 | 84 | $db4->{$mirror_type} = { 85 | 'country' => {}, 'arch' => {}, 86 | 'AS' => {}, 'continent' => {}, 87 | 'master' => '', 'serial' => {} 88 | }; 89 | $full_db{$mirror_type} = $db4->{$mirror_type}; 90 | $db6->{$mirror_type} = { 91 | 'country' => {}, 'arch' => {}, 92 | 'AS' => {}, 'continent' => {}, 93 | 'master' => '', 'serial' => {} 94 | }; 95 | } 96 | $db4->{'all'} = {}; 97 | $db6->{'all'} = {}; 98 | $full_db{'all'} = $db4->{'all'}; 99 | 100 | $full_db{'id'} = time; 101 | 102 | my ($g_city4, $g_as4, $g_city6, $g_as6); 103 | $g_city4 = Geo::IP->open('geoip/GeoLiteCity.dat', GEOIP_MMAP_CACHE) 104 | or die; 105 | $g_as4 = Geo::IP->open('geoip/GeoIPASNum.dat', GEOIP_MMAP_CACHE) 106 | or die; 107 | $g_city6 = Geo::IP->open('geoip/GeoLiteCityv6.dat', GEOIP_MMAP_CACHE) 108 | or die; 109 | $g_as6 = Geo::IP->open('geoip/GeoIPASNumv6.dat', GEOIP_MMAP_CACHE) 110 | or die; 111 | 112 | my $remaining_entries = scalar(@data); 113 | for my $entry (@data) { 114 | if (query_dns_for_entry($entry)) { 115 | if (exists($entry->{'ipv4'})) { 116 | delete $entry->{'ipv4'}; 117 | AnyEvent::DNS::a $entry->{'site'}, sub { 118 | process_entry4(dclone($entry), @_); 119 | $cv->send if (--$remaining_entries == 0); 120 | }; 121 | } 122 | if (exists($entry->{'ipv6'})) { 123 | # we now only use it as a flag here 124 | delete $entry->{'ipv6'}; 125 | $remaining_entries++; 126 | AnyEvent::DNS::aaaa $entry->{'site'}, sub { 127 | process_entry6(dclone($entry), @_); 128 | $cv->send if (--$remaining_entries == 0); 129 | }; 130 | } 131 | } else { 132 | $cv->send if (--$remaining_entries == 0); 133 | } 134 | } 135 | 136 | $cv->recv; 137 | 138 | if (!exists($db4->{'archive'}{'arch'}{'i386'}) || scalar(keys %{$db4->{'archive'}{'arch'}{'i386'}}) < 10) { 139 | print STDERR "error: not even 10 mirrors with i386 found on the archive list, not saving\n"; 140 | } else { 141 | Mirror::DB::set($db_output); 142 | Mirror::DB::store(\%full_db); 143 | } 144 | 145 | exit; 146 | 147 | sub parse_list($$) { 148 | my ($file, $sites_ref) = @_; 149 | 150 | my @data; 151 | my $group; 152 | my $field; 153 | 154 | open(MLIST, '<', $file) 155 | or die ("could not open $file for reading: $!"); 156 | 157 | local $_; 158 | while () { 159 | chomp; 160 | 161 | if (m/^\s*$/) { 162 | $group = undef; 163 | next; 164 | } 165 | elsif (m/^(\S+):\s*(.*?)\s*$/) { 166 | # skip commented-out lines: 167 | next if (substr($1, 0, 2) eq 'X-'); 168 | 169 | unless (defined $group) { 170 | $group = {}; 171 | push @data, $group; 172 | } 173 | 174 | $field = lc $1; 175 | my $value = $2; 176 | 177 | $group->{$field} = $value; 178 | # We need this list before we process the sites themselves 179 | # so we can't build it as we process them. 180 | # Purists might prefer to add another iteration to build 181 | # it, but I don't mind doing this only one extra thing here: 182 | $sites_ref->{$value} = undef 183 | if ($field eq 'site'); 184 | next; 185 | } 186 | elsif (m/^\s+(.*?)\s*$/) { 187 | 188 | if (!defined($group)) { 189 | warn ("syntax error: found lone field continuation"); 190 | next; 191 | } 192 | my $value = $1; 193 | $group->{$field} .= "\n" . $value; 194 | next; 195 | } 196 | else { 197 | warn ("syntax error: found lone data"); 198 | next; 199 | } 200 | } 201 | close(MLIST); 202 | 203 | return @data; 204 | } 205 | 206 | sub query_dns_for_entry($) { 207 | my $entry = shift; 208 | 209 | $entry->{'type'} = lc ($entry->{'type'} || 'unknown'); 210 | 211 | return 0 if ($entry->{'type'} =~ m/^(?:unknown|geodns)$/ && $entry->{'site'} ne 'security.debian.org'); 212 | 213 | if ($entry->{'site'} eq 'security.debian.org') { 214 | # used to indicate that even if only this site has a newer 215 | # master trace, all other mirrors should be disabled 216 | $entry->{'security-reference'} = 'yes'; 217 | 218 | # not really relevant, yet this is needed by the rest of the code 219 | $entry->{'country'} = 'US United States'; 220 | } 221 | 222 | if ($entry->{'type'} eq 'origin') { 223 | foreach my $type (@mirror_types) { 224 | next if ($exclude_mirror_types{$type}); 225 | next unless (exists($entry->{$type.'-rsync'})); 226 | 227 | $db4->{$type}{'master'} = $entry->{'site'}; 228 | $db6->{$type}{'master'} = $entry->{'site'}; 229 | } 230 | return 0; 231 | } 232 | 233 | if (!defined($entry->{'site'})) { 234 | print STDERR "warning: mirror without site:\n"; 235 | require Data::Dumper; 236 | print STDERR Data::Dumper::Dumper($entry); 237 | return 0; 238 | } 239 | 240 | my $got_http = 0; 241 | foreach my $type (@mirror_types) { 242 | next if ($exclude_mirror_types{$type}); 243 | 244 | # some mirrors should not appear in public lists, so they are 245 | # added as "unlisted" entries. Internally, consider them to be 246 | # just like any other mirror 247 | if (exists($entry->{$type.'-unlisted-http'})) { 248 | $entry->{$type.'-http'} = $entry->{$type.'-unlisted-http'}; 249 | delete $entry->{$type.'-unlisted-http'}; 250 | } 251 | 252 | next unless (exists($entry->{$type.'-http'})); 253 | 254 | $got_http = 1; 255 | } 256 | unless ($got_http) { 257 | print "info: $entry->{'site'} is not an HTTP mirror, skipping\n" 258 | if ($verbose); 259 | return 0; 260 | } 261 | 262 | # By default consider all mirrors to have v4 connectivity 263 | $entry->{'ipv4'} = undef; 264 | if (defined ($entry->{'ipv6'})) { 265 | if ($entry->{'ipv6'} eq 'only') { 266 | $entry->{'ipv6'} = undef; 267 | delete $entry->{'ipv4'}; 268 | } elsif ($entry->{'ipv6'} eq 'yes') { 269 | $entry->{'ipv6'} = undef; 270 | } elsif ($entry->{'ipv6'} eq 'no') { 271 | delete $entry->{'ipv6'}; 272 | } else { 273 | print STDERR "warning: unknown ipv6 value: '$entry->{'ipv6'}'\n"; 274 | return 0; 275 | } 276 | } 277 | 278 | if (defined ($entry->{'includes'})) { 279 | my @includes = split /\s+/ , $entry->{'includes'}; 280 | my $missing = 0; 281 | foreach my $include (@includes) { 282 | next if (exists ($all_sites{$include})); 283 | 284 | print "info: $entry->{'site'} includes $include\n"; 285 | print "\tbut it doesn't have its own entry, not cloning\n"; 286 | $missing = 1; 287 | } 288 | if (!$missing) { 289 | print "info: $entry->{'site'} has Includes, all with their own entry, skipping\n" 290 | if ($verbose); 291 | return 0; 292 | } 293 | } 294 | 295 | if (defined ($entry->{'restricted-to'})) { 296 | print STDERR "warning: skipping $entry->{'site'}, Restricted-To support is buggy\n"; 297 | return 0; 298 | if ($entry->{'restricted-to'} =~ m/^(?:strict-country|subnet)$/) { 299 | print STDERR "warning: unsupported Restricted-To $entry->{'restricted-to'}\n"; 300 | return 0; 301 | } 302 | if ($entry->{'restricted-to'} !~ m/^(?:AS|country)$/) { 303 | print STDERR "warning: unknown Restricted-To value: '$entry->{'restricted-to'}'\n"; 304 | return 0; 305 | } 306 | } else { 307 | $entry->{'restricted-to'} = ''; 308 | } 309 | 310 | return 1; 311 | } 312 | 313 | sub process_entry6($@) { 314 | my $entry = shift; 315 | my @ips = @_; 316 | my $name = $entry->{'site'}.'/ipv6'; 317 | 318 | return process_entry_common($db6, $name, $entry, 319 | sub { return $g_as6->org_by_addr_v6(shift)}, 320 | sub { return $g_city6->record_by_addr_v6(shift)}, 321 | @_); 322 | } 323 | 324 | sub process_entry4($@) { 325 | my $entry = shift; 326 | my @ips = @_; 327 | my $name = $entry->{'site'}.'/ipv4'; 328 | 329 | return process_entry_common($db4, $name, $entry, 330 | sub { return $g_as4->org_by_addr(shift)}, 331 | sub { return $g_city4->record_by_addr(shift)}, 332 | @_); 333 | } 334 | 335 | sub process_entry_common($$$$$@) { 336 | my $db = shift; 337 | my $name = shift; 338 | my $entry = shift; 339 | my $as_of_ip = shift; 340 | my $grec_of_ip = shift; 341 | my @ips = @_; 342 | 343 | if (!@ips || scalar(@ips) == 0) { 344 | print STDERR "warning: host lookup for $name failed\n"; 345 | return; 346 | } 347 | 348 | my ($r, $as) = (undef, ''); 349 | $as = $entry->{'as'} if (defined($entry->{'as'})); 350 | # Consider: lookup all possible IPs and try to match them to a unique host 351 | # However: we can't control what IP the client will connect to, and 352 | # we can't guarantee that accessing the mirror with a different 353 | # Host will actually work. Meh. 354 | my %as_seen; 355 | for my $ip (@ips) { 356 | my $m_record = &$grec_of_ip($ip); 357 | # Split result, original format is: "AS123 Foo Bar corp" 358 | my ($m_as) = split /\s+/, (&$as_of_ip($ip) || ''); 359 | 360 | if (!defined($r)) { 361 | $r = $m_record; 362 | } elsif ($r->city ne $m_record->city) { 363 | print STDERR "warning: ".$name." resolves to IPs in different". 364 | " cities (".$r->city." != ".$m_record->city.")\n"; 365 | } 366 | if (!$as) { 367 | $as = $m_as; 368 | } elsif (defined($m_as) && $as ne $m_as) { 369 | print STDERR "warning: ".$name." resolves to multiple different". 370 | " AS' ($as != $m_as)\n" unless (exists($as_seen{$m_as})); 371 | $as_seen{$m_as} = 1; 372 | } 373 | } 374 | 375 | if (!defined($r) || !$as) { 376 | print STDERR "warning: GeoIP/AS db lookup failed for $name\n"; 377 | return; 378 | } 379 | my $country = $r->country_code || 'A1'; 380 | my ($listed_country) = split /\s+/, $entry->{'country'}; 381 | my $continent = $r->continent_code || 'XX'; 382 | my ($lat, $lon) = ($r->latitude, $r->longitude); 383 | $as = Mirror::AS::convert($as); 384 | 385 | # A1: Anonymous proxies 386 | # A2: Satellite providers 387 | # EU: Europe 388 | # AP: Asia/Pacific region 389 | if ($country =~ m/^(?:A1|A2|EU|AP)$/ || defined($entry->{'geoip-override'})) { 390 | if (!defined($entry->{'geoip-override'})) { 391 | print STDERR "warning: non-definitive country ($country) entry in GeoIP db for $name\n"; 392 | print STDERR "\tusing listed country ($listed_country)"; 393 | } else { 394 | print STDERR "warning: overriding country of $name"; 395 | } 396 | $country = $listed_country; 397 | $continent = $g_city4->continent_code_by_country_code($country); 398 | 399 | print STDERR ", fixing continent to '$continent'"; 400 | 401 | require Mirror::CountryCoords; 402 | my $coords = Mirror::CountryCoords::country($country); 403 | if ($coords) { 404 | $lat = $coords->{'lat'}; 405 | $lon = $coords->{'lon'}; 406 | print STDERR " and country coordinates\n"; 407 | } else { 408 | print STDERR ", but country coordinates could not be found\n"; 409 | } 410 | 411 | # If provided, fix the latitude and longitude 412 | if (defined($entry->{'lat'})) { 413 | $lat = $entry->{'lat'}; 414 | } 415 | if (defined($entry->{'lon'})) { 416 | $lon = $entry->{'lon'}; 417 | } 418 | 419 | } elsif ($listed_country ne $country) { 420 | print STDERR "warning: listed country for $name doesn't match GeoIP db\n"; 421 | print STDERR "\t$listed_country (listed) vs $country (db), "; 422 | print STDERR "using geoip db's entry\n"; 423 | } 424 | 425 | # Generate a unique id for this site 426 | my $id = $i++; 427 | # When used as hash key, it is converted to a string. 428 | # Better store it as a string everywhere: 429 | $id = sprintf('%x', $id); 430 | 431 | $entry->{'lat'} = $lat; 432 | $entry->{'lon'} = $lon; 433 | 434 | # Remove trailing zeros 435 | for my $coord_type (qw(lat lon)) { 436 | next unless ($entry->{$coord_type} =~ m/\./); 437 | $entry->{$coord_type} =~ s/0+$//; 438 | $entry->{$coord_type} =~ s/\.$//; 439 | } 440 | 441 | if (defined($entry->{'bandwidth'})) { 442 | eval { 443 | $entry->{'bandwidth'} = bandwidth_to_mb($entry->{'bandwidth'}); 444 | }; 445 | if ($@) { 446 | print STDERR "warning: $@ for $name\n"; 447 | delete $entry->{'bandwidth'}; 448 | } 449 | } 450 | 451 | my $mirror_recorded = 0; 452 | 453 | foreach my $type (@mirror_types) { 454 | if ($exclude_mirror_types{$type}) { 455 | delete $entry->{$type.'-http'}; 456 | next; 457 | } 458 | 459 | next unless (defined($entry->{$type.'-http'})); 460 | 461 | if (!defined($entry->{$type.'-architecture'}) && $type eq 'archive') { 462 | print STDERR "warning: no $type-architecture list for $name\n"; 463 | next; 464 | } 465 | 466 | if (!defined($entry->{$type.'-architecture'})) { 467 | $entry->{$type.'-architecture'} = 'ANY'; 468 | } 469 | 470 | my %archs = map { lc $_ => 1 } 471 | split(/\s+/, $entry->{$type.'-architecture'}); 472 | 473 | # Now store the results 474 | unless ($mirror_recorded) { 475 | $db->{'all'}{$id} = $entry; 476 | $mirror_recorded = 1; 477 | } 478 | 479 | # Create skeleton, if missing: 480 | $db->{$type}{'AS'}{$as} = [] 481 | unless (exists ($db->{$type}{'AS'}{$as})); 482 | push @{$db->{$type}{'AS'}{$as}}, $id; 483 | 484 | unless ($entry->{'restricted-to'} eq 'AS') { 485 | $db->{$type}{'country'}{$country} = {} 486 | unless (exists ($db->{$type}{'country'}{$country})); 487 | $db->{$type}{'country'}{$country}{$id} = undef; 488 | 489 | unless ($entry->{'restricted-to'} eq 'country') { 490 | $db->{$type}{'continent'}{$continent} = {} 491 | unless (exists ($db->{$type}{'continent'}{$continent})); 492 | $db->{$type}{'continent'}{$continent}{$id} = undef; 493 | } 494 | } 495 | 496 | foreach my $arch (keys %archs) { 497 | # more skeletons... 498 | $db->{$type}{'arch'}{$arch} = {} 499 | unless (exists ($db->{$type}{'arch'}{$arch})); 500 | 501 | $db->{$type}{'arch'}{$arch}{$id} = undef; 502 | } 503 | # end: now store the results 504 | } 505 | 506 | # remove any remaining fields we don't use 507 | my %wanted_fields = map { $_ => 1 } qw( 508 | bandwidth 509 | lat 510 | lon 511 | site 512 | restricted-to 513 | trace-file 514 | ); 515 | for my $key (keys %{$entry}) { 516 | next if ($key =~ m/-http$/); 517 | next if ($key =~ m/-reference$/); 518 | 519 | if (defined($wanted_fields{$key})) { 520 | # undef has a special meaning 521 | next if (!defined($entry->{$key})); 522 | # empty fields are not useful 523 | next if (length($entry->{$key})); 524 | } 525 | delete $entry->{$key}; 526 | } 527 | } 528 | 529 | sub bandwidth_to_mb($) { 530 | my $bw_str = shift; 531 | my $bw = 0; 532 | 533 | if ($bw_str =~ m/([\d.]+)\s*([tgm])/i) { 534 | my ($quantity, $unit) = ($1, $2); 535 | $unit = lc $unit; 536 | while ($unit ne 'm') { 537 | if ($unit eq 't') { 538 | $quantity *= 1000; 539 | $unit = 'g'; 540 | } 541 | if ($unit eq 'g') { 542 | $quantity *= 1000; 543 | $unit = 'm'; 544 | } 545 | } 546 | $bw = $quantity; 547 | } else { 548 | die "unknown bandwidth format ($bw_str)\n"; 549 | } 550 | return $bw; 551 | } 552 | 553 | sub get_lists($) { 554 | my $input_dir = shift; 555 | my @lists; 556 | my $dh; 557 | 558 | opendir($dh, $input_dir) 559 | or die("error: could not open '$input_dir' directory: $!\n"); 560 | @lists = grep { m/\.masterlist$/ && s,^,$input_dir/, } readdir($dh); 561 | closedir($dh); 562 | 563 | return @lists; 564 | } 565 | -------------------------------------------------------------------------------- /build-peers-db.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | #################### 4 | # Copyright (C) 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Storable qw(retrieve); 27 | use Mirror::AS; 28 | use Mirror::DB; 29 | 30 | use Getopt::Long; 31 | 32 | my $mirrors_db_file = 'db'; 33 | my $print_progress = 0; 34 | my $max_distance = -1; 35 | my $max_peers = 100; 36 | my $store_distance = 0; 37 | my $db_out = 'db.peers'; 38 | my $input_dir = 'peers.lst.d'; 39 | 40 | GetOptions('mirrors-db=s' => \$mirrors_db_file, 41 | 'progress!' => \$print_progress, 42 | 'peers-limit=i' => \$max_peers, 43 | 'list-directory=s' => \$input_dir, 44 | 'distance=i' => \$max_distance, 45 | 'store-distance!' => \$store_distance, 46 | 's|store-db=s' => \$db_out) or exit 1; 47 | 48 | our $mirrors_db = retrieve($mirrors_db_file); 49 | 50 | if (exists($mirrors_db->{'id'})) { 51 | $db_out .= '-'.$mirrors_db->{'id'}; 52 | } 53 | 54 | my %peers_db; 55 | my $count = -1; 56 | my %site2id; 57 | my %AS2ids; 58 | my %id_counter; 59 | my @input_files; 60 | 61 | sub build_site2id_index; 62 | sub build_AS2ids_index; 63 | sub get_lists($); 64 | 65 | die("error: '$input_dir' is not a directory\n") 66 | unless (-d $input_dir); 67 | 68 | @input_files = get_lists($input_dir); 69 | 70 | $count = 0 if ($print_progress); 71 | 72 | for my $list (sort @input_files) { 73 | my $fh; 74 | open($fh, '<', $list) 75 | or die("error: could not open '$list' for reading\n"); 76 | 77 | while (<$fh>) { 78 | chomp; 79 | # allow comments and empty lines 80 | next if ($_ eq '' || m/^\s*#/); 81 | 82 | my @parts = split; 83 | die "malformed input" unless (scalar(@parts) >= 2); 84 | 85 | my @clientsASN = shift @parts; 86 | my @dests = shift @parts; 87 | my $dist = int(shift @parts || 0); 88 | my %ipv = map { s/^v//; $_ => 1 } split(/,/, shift @parts || 'v4'); 89 | 90 | if ($count != -1 && ($count++)%1000 == 0) { 91 | print STDERR "Processed: $count...\r"; 92 | } 93 | 94 | # The db is IPv4-only, for now: 95 | next unless (defined($ipv{4})); 96 | 97 | next unless ($max_distance == -1 || $dist < $max_distance); 98 | 99 | if ($clientsASN[0] =~ s/^\{// && $clientsASN[0] =~ s/\}$//) { 100 | @clientsASN = split (/,/, $clientsASN[0]); 101 | } 102 | 103 | # allow the destination to be specified as the domain name of the 104 | # mirror 105 | if ($dests[0] !~ m/^(?:AS)?(?:\d\.)?\d+$/) { 106 | %site2id or %site2id = build_site2id_index; 107 | if (!exists($site2id{$dests[0]})) { 108 | die "Unknown site ".$dests[0]; 109 | } 110 | $dests[0] = $site2id{$dests[0]}; 111 | } else { 112 | %AS2ids or %AS2ids = build_AS2ids_index; 113 | $dests[0] = Mirror::AS::convert($dests[0]); 114 | 115 | next unless (exists($AS2ids{$dests[0]})); 116 | @dests = @{$AS2ids{$dests[0]}}; 117 | } 118 | 119 | for my $client (@clientsASN) { 120 | $client = Mirror::AS::convert($client); 121 | 122 | $peers_db{$client} = {} 123 | unless (exists($peers_db{$client})); 124 | 125 | for my $dest (@dests) { 126 | my $min_dist = undef; 127 | 128 | if ($store_distance) { 129 | $min_dist = $dist; 130 | $min_dist = $peers_db{$client}->{$dest} 131 | if (exists($peers_db{$client}->{$dest}) && $peers_db{$client}->{$dest} < $min_dist); 132 | } 133 | $id_counter{$dest} = (exists($id_counter{$dest})?$id_counter{$dest}+1:1) 134 | unless (exists($peers_db{$client}->{$dest})); 135 | $peers_db{$client}->{$dest} = $min_dist; 136 | } 137 | } 138 | } 139 | close($fh); 140 | } 141 | 142 | my @sorted_ids = sort { $id_counter{$b} <=> $id_counter{$a} } keys %id_counter; 143 | for my $id (@sorted_ids) { 144 | if ($id_counter{$id} > $max_peers) { 145 | print "Ignoring mirror $id, it has $id_counter{$id} peers\n"; 146 | for my $AS (keys %peers_db) { 147 | delete $peers_db{$AS}{$id}; 148 | delete $peers_db{$AS} 149 | if (scalar(keys %{$peers_db{$AS}}) == 0); 150 | } 151 | } else { 152 | last; 153 | } 154 | } 155 | 156 | 157 | Mirror::DB::set($db_out); 158 | Mirror::DB::store(\%peers_db); 159 | 160 | sub build_site2id_index { 161 | my %site2id; 162 | for my $id (keys %{$mirrors_db->{'all'}}) { 163 | $site2id{$mirrors_db->{'all'}{$id}{'site'}} = $id; 164 | } 165 | return %site2id; 166 | } 167 | 168 | # Build a map[AS]=>site_id 169 | sub build_AS2ids_index { 170 | my %AS2site; 171 | for my $type (keys %{$mirrors_db}) { 172 | next if ($type eq 'all' || $type eq 'id'); 173 | for my $AS (keys %{$mirrors_db->{$type}{'AS'}}) { 174 | for my $id (@{$mirrors_db->{$type}{'AS'}{$AS}}) { 175 | $AS2site{$AS} = {} 176 | unless exists($AS2site{$AS}); 177 | $AS2site{$AS}{$id} = undef; 178 | } 179 | 180 | } 181 | } 182 | for my $AS (keys %AS2site) { 183 | my @ids = keys %{$AS2site{$AS}}; 184 | $AS2site{$AS} = \@ids; 185 | } 186 | return %AS2site; 187 | } 188 | 189 | sub get_lists($) { 190 | my $input_dir = shift; 191 | my @lists; 192 | my $dh; 193 | 194 | opendir($dh, $input_dir) 195 | or die("error: could not open '$input_dir' directory: $!\n"); 196 | @lists = grep { m/\.lst$/ && s,^,$input_dir/, } readdir($dh); 197 | closedir($dh); 198 | 199 | return @lists; 200 | } 201 | -------------------------------------------------------------------------------- /build-report.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | #################### 4 | # Copyright (C) 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Getopt::Long; 27 | use Storable qw(retrieve); 28 | 29 | sub print_note; 30 | 31 | our $print_note_block; 32 | my $db_store = 'db'; 33 | 34 | GetOptions('db-store=s' => \$db_store); 35 | 36 | my $db = retrieve($db_store); 37 | 38 | my %tags_bad = ( 39 | "badmaster" => "Bad master trace", 40 | "badsite" => "Bad site trace", 41 | "badsubset" => "In a too old, new, or incomplete subset", 42 | "stages-disabled" => "Doesn't perform two-stages sync", 43 | "archcheck-disabled" => "Missing all architectures, or source packages", 44 | "areascheck-disabled" => "Missing archive areas (main, contrib, or non-free)", 45 | "file-disabled" => "Blocklisted", 46 | "notinrelease" => "Not reliable for serving InRelease files", 47 | "noti18n" => "Not reliable for serving i18n/ files", 48 | "oldftpsync" => "Too old ftpsync", 49 | "oldsite" => "Site trace older than master, possibly syncing", 50 | ); 51 | 52 | my %tags_good = ( 53 | "ranges" => "Doesn't seem to support Range requests", 54 | "keep-alive" => "Doesn't seem to support Keep-Alive connections", 55 | ); 56 | 57 | print "Mirrors db report\n"; 58 | print "=================\n"; 59 | 60 | for my $ipv (sort keys %{$db}) { 61 | next unless (ref($db->{$ipv}) && exists($db->{$ipv}{'all'})); 62 | 63 | my $ldb = $db->{$ipv}; 64 | my $postfix = ''; 65 | $postfix = "-$ipv" if ($ipv ne 'ipv4'); 66 | 67 | for my $id (sort keys %{$ldb->{'all'}}) { 68 | my $mirror = $ldb->{'all'}{$id}; 69 | my @mirror_types; 70 | 71 | print "\nMirror: $mirror->{site}$postfix\n"; 72 | 73 | for my $k (keys %$mirror) { 74 | next unless ($k =~ m/^(.+)-http$/); 75 | push @mirror_types, $1; 76 | } 77 | for my $type (sort @mirror_types) { 78 | $print_note_block = 1; 79 | print "- Type: $type\n"; 80 | print " Status: ",(exists($mirror->{"$type-disabled"})?"disabled":"enabled"),"\n"; 81 | print " State: ",(($mirror->{"$type-state"} eq "syncing")?"syncing":"synced"),"\n" 82 | if (defined($mirror->{"$type-state"})); 83 | print " Path: ",$mirror->{"$type-http"},"\n"; 84 | 85 | foreach my $k (sort keys (%tags_bad)) { 86 | print_note $tags_bad{$k} 87 | if (exists($mirror->{$type.'-'.$k})); 88 | } 89 | 90 | foreach my $k (sort keys (%tags_good)) { 91 | print_note $tags_good{$k} 92 | if (!exists($mirror->{$type.'-'.$k})); 93 | } 94 | 95 | if (defined($mirror->{"$type-master"}) and defined($mirror->{"$type-site"})) { 96 | my $delay = int(($mirror->{"$type-site"} - $mirror->{"$type-master"})/60); 97 | my $last_update = localtime($mirror->{"$type-site"}); 98 | print_note "Last update: $last_update"; 99 | print_note "Sync delay: $delay min"; 100 | } 101 | 102 | for my $key (keys %{$mirror}) { 103 | next unless ($key =~ m/^\Q$type-\E/); 104 | if ($key =~ m/^\Q$type-\E(.+?)(-trace)?-disabled$/) { 105 | my $arch = $1; 106 | next if (exists($mirror->{$type.'-archcheck-disabled'})); 107 | next unless (exists($ldb->{$type}{'arch'}{$arch})); 108 | 109 | # If disabled by trace file: 110 | if (defined($2)) { 111 | print_note "Dropped architecture: $arch, but listed"; 112 | # Don't report it twice: 113 | } elsif (!exists($mirror->{"$type-$arch-trace-disabled"})) { 114 | print_note "Missing architecture: $arch, but listed"; 115 | } 116 | } 117 | } 118 | } 119 | } 120 | } 121 | 122 | sub print_note { 123 | my $note = shift; 124 | if ($print_note_block) { 125 | print " Notes:\n"; 126 | $print_note_block = 0; 127 | } 128 | print " $note\n"; 129 | } 130 | -------------------------------------------------------------------------------- /check.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | #################### 4 | # Copyright (C) 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Getopt::Long; 27 | use Storable qw(retrieve); 28 | use HTTP::Date qw(); 29 | 30 | use lib '.'; 31 | use Mirror::DB; 32 | use Mirror::Trace; 33 | use Mirror::RateLimiter; 34 | 35 | use AnyEvent; 36 | use AnyEvent::HTTP; 37 | 38 | sub head_url($$$); 39 | sub test_arch($$$$); 40 | sub test_source($$$); 41 | sub test_areas($$$); 42 | sub test_stages($$$$); 43 | sub check_mirror($$); 44 | sub check_mirror_post_master($$$$$); 45 | sub log_message($$$); 46 | sub mirror_is_good($$); 47 | sub archs_by_mirror($$); 48 | sub parse_disable_file($); 49 | sub fatal_connection_error($); 50 | sub disable_mirrors($$@); 51 | sub mark_bad_subset($$@); 52 | sub mirror_provides_arch($$$); 53 | sub mirror_types_to_check($); 54 | sub store_not_too_much($$$); 55 | sub disabled_this_session($$); 56 | sub callback_return($); 57 | 58 | my $db_store = 'db'; 59 | my $db_output = $db_store; 60 | my $check_archs = ''; 61 | my $check_trace_archs = 1; 62 | my $check_areas = ''; 63 | my $check_2stages = 1; 64 | my $check_everything = 0; 65 | my $incoming_db = ''; 66 | my $disable_sites = 'sites.disabled'; 67 | my $threads = -1; 68 | my $verbose = 0; 69 | my @ids; 70 | my @ipv_to_check; 71 | 72 | GetOptions('check-architectures!' => \$check_archs, 73 | 'check-areas!' => \$check_areas, 74 | 'check-2stages!' => \$check_2stages, 75 | 'check-trace-architectures!' => \$check_trace_archs, 76 | 'check-everything' => \$check_everything, 77 | 'j|threads=i' => \$threads, 78 | 'db-store=s' => \$db_store, 79 | 'db-output=s' => \$db_output, 80 | 'id|mirror-id=s' => \@ids, 81 | 'incoming-db=s' => \$incoming_db, 82 | 'disable-sites=s' => \$disable_sites, 83 | 'ipv=i' => \@ipv_to_check, 84 | 'verbose!' => \$verbose) or exit 1; 85 | 86 | # Avoid picking up db.in when working on db.wip, for example 87 | $incoming_db ||= $db_store.'.in'; 88 | scalar(@ipv_to_check) or @ipv_to_check = qw(4 6); 89 | 90 | my %max_age = ( 91 | 'default' => 13*3600, 92 | ); 93 | 94 | if ($check_everything) { 95 | $check_archs = 1 unless ($check_archs ne ''); 96 | $check_areas = 1 unless ($check_areas ne ''); 97 | $check_trace_archs = 1 unless ($check_trace_archs ne ''); 98 | $check_2stages = 1 unless ($check_2stages ne ''); 99 | } 100 | 101 | $| = 1; 102 | 103 | $AnyEvent::HTTP::MAX_RECURSE = 0; 104 | $AnyEvent::HTTP::TIMEOUT = 10; 105 | $AnyEvent::HTTP::MAX_PER_HOST = 1; 106 | $AnyEvent::HTTP::USERAGENT = "MirrorChecker/0.2 "; 107 | 108 | our $db; 109 | my $full_db = undef; 110 | our %sites_to_disable; 111 | 112 | if (-f $disable_sites) { 113 | eval { 114 | %sites_to_disable = %{parse_disable_file($disable_sites)}; 115 | }; 116 | # If there was an exception take it as if we hadn't been requested to 117 | # process the file 118 | if ($@) { 119 | warn $@; 120 | $disable_sites = ''; 121 | } 122 | } 123 | 124 | if ($incoming_db) { 125 | # The db might be gone or not exist at all 126 | eval { $full_db = retrieve($incoming_db); }; 127 | if ($@) { 128 | $full_db = undef; 129 | $incoming_db = ''; 130 | } 131 | } 132 | $full_db = retrieve($db_store) 133 | unless (defined($full_db)); 134 | 135 | print "{db:",($incoming_db||$db_store),"}\n"; 136 | 137 | if (scalar(@ids) && $incoming_db) { 138 | die("error: passed --id but there's an incoming db: $incoming_db\n"); 139 | } 140 | 141 | Mirror::DB::set($db_output); 142 | 143 | our $cv; 144 | our %traces; 145 | our %just_disabled; 146 | our $process_stamps; 147 | 148 | for my $ipv (@ipv_to_check) { 149 | undef %traces; 150 | undef %just_disabled; 151 | $process_stamps = 0; 152 | $cv = AnyEvent::condvar; 153 | 154 | # Modify AE's PROTOCOL to force one or the other family 155 | if ($ipv == 4) { 156 | $db = $full_db->{'ipv4'}; 157 | $AnyEvent::PROTOCOL{ipv4} = 1; 158 | $AnyEvent::PROTOCOL{ipv6} = 0; 159 | } elsif ($ipv == 6) { 160 | $db = $full_db->{'ipv6'}; 161 | $AnyEvent::PROTOCOL{ipv4} = 0; 162 | $AnyEvent::PROTOCOL{ipv6} = 1; 163 | } else { 164 | die("error: unknown IP family '$ipv'\n"); 165 | } 166 | 167 | my @ids_to_process = @ids; 168 | unless (scalar(@ids_to_process)) { 169 | @ids_to_process = keys %{$db->{'all'}}; 170 | $process_stamps = 1; 171 | } 172 | 173 | $cv->begin; 174 | for my $id (@ids_to_process) { 175 | for my $type (mirror_types_to_check($id)) { 176 | check_mirror($id, $type); 177 | } 178 | } 179 | $cv->end; 180 | $cv->recv; 181 | 182 | for my $type (keys %traces) { 183 | my @stamps = sort { $b <=> $a } keys %{$traces{$type}}; 184 | 185 | next unless ($process_stamps); 186 | 187 | my %master_stamps; 188 | my $global_master_stamp; 189 | 190 | for my $stamp (@stamps) { 191 | my $is_type_ref = has_type_reference($type, @{$traces{$type}{$stamp}}); 192 | 193 | if (scalar(@{$traces{$type}{$stamp}}) <= 2 && !$is_type_ref) { 194 | mark_bad_subset($type, "old or not popular master stamp '$stamp'", @{$traces{$type}{$stamp}}); 195 | next; 196 | } 197 | 198 | for my $continent (keys %{$db->{$type}{'continent'}}) { 199 | my @per_continent; 200 | my $good_mirrors = 0; 201 | my %archs_required = map { $_ => 1 } qw(amd64 i386); 202 | 203 | for my $id (@{$traces{$type}{$stamp}}) { 204 | next unless (exists($db->{$type}{'continent'}{$continent}{$id})); 205 | 206 | my $mirror = $db->{'all'}{$id}; 207 | 208 | $good_mirrors++ if (mirror_is_good($mirror, $type)); 209 | 210 | for my $arch (keys %archs_required) { 211 | delete $archs_required{$arch} 212 | if (mirror_provides_arch($id, $type, $arch) || mirror_provides_arch($id, $type, 'any')); 213 | } 214 | 215 | push @per_continent, $id; 216 | } 217 | 218 | # Criteria: at least one mirror 219 | # Criteria: at least one that is "good" 220 | unless (scalar(@per_continent) && $good_mirrors) { 221 | mark_bad_subset($type, "Not enough good mirrors in its $continent subset", @per_continent); 222 | next; 223 | } 224 | # Criteria: at least %archs_required can be served 225 | if ($type eq 'archive' && scalar(keys %archs_required)) { 226 | mark_bad_subset($type, "Required archs not present in its $continent subset", @per_continent); 227 | next; 228 | } 229 | 230 | if (!exists($master_stamps{$continent})) { 231 | # Do not let subsets become too old 232 | if (defined($global_master_stamp) && 233 | (($global_master_stamp - $stamp) > ($max_age{$type} || $max_age{'default'}) || 234 | $type eq 'security' || $is_type_ref)) { 235 | print "Overriding the master stamp of $type/$continent (from $stamp to $global_master_stamp)\n"; 236 | $master_stamps{$continent} = $global_master_stamp; 237 | } elsif (!defined($global_master_stamp)) { 238 | $global_master_stamp = $stamp; 239 | } 240 | } 241 | 242 | if (exists($master_stamps{$continent})) { 243 | # if a master stamp has been recorded already it means 244 | # there are more up to date mirrors 245 | mark_bad_subset($type, "old master trace re $continent", @per_continent); 246 | } else { 247 | if (exists($db->{$type}{'serial'})) { 248 | $db->{$type}{'serial'}{$continent} = 0 249 | unless (exists($db->{$type}{'serial'}{$continent})); 250 | 251 | print "Regression detected in $continent/$type\n" 252 | if ($db->{$type}{'serial'}{$continent} > $stamp); 253 | 254 | $db->{$type}{'serial'}{$continent} = $stamp; 255 | } 256 | $master_stamps{$continent} = $stamp; 257 | print "Master stamp for $continent/$type: $stamp\n"; 258 | } 259 | } 260 | } 261 | 262 | my @continents_by_stamp = sort {$master_stamps{$a} <=> $master_stamps{$b}} 263 | keys %master_stamps; 264 | 265 | if (scalar(@continents_by_stamp)) { 266 | my $recent_stamp = $master_stamps{$continents_by_stamp[-1]}; 267 | 268 | while (my $continent = pop @continents_by_stamp) { 269 | my $diff = ($recent_stamp - $master_stamps{$continent})/3600; 270 | 271 | if ($diff == 0) { 272 | print "Subset $continent/$type is up to date\n"; 273 | } else { 274 | print "Subset $continent/$type is $diff hour(s) behind\n"; 275 | } 276 | } 277 | } 278 | } 279 | 280 | Mirror::DB::store($full_db); 281 | } 282 | 283 | 284 | # If we used an 'incoming' db, delete it after storing it as the normal 285 | # db. If any other process picked the incoming db too, well, they will 286 | # be using the same data we used, so it's okay. 287 | # This assumes that any other process will have been started after us, 288 | # or finished before use otherwise 289 | if ($incoming_db) { 290 | unlink($incoming_db); 291 | } 292 | 293 | sub mirror_is_good($$) { 294 | my ($mirror, $type) = @_; 295 | 296 | return 0 if (exists($mirror->{$type.'-disabled'})); 297 | 298 | return 1 if ($type eq 'old'); 299 | 300 | return 0 if (exists($mirror->{$type.'-notinrelease'})); 301 | return 0 if (exists($mirror->{$type.'-noti18n'})); 302 | 303 | return 1; 304 | } 305 | 306 | sub has_type_reference { 307 | my $type = shift; 308 | 309 | for my $id (@_) { 310 | return 1 if (exists($db->{'all'}{$id}{$type.'-reference'})); 311 | } 312 | return 0; 313 | } 314 | 315 | sub head_url($$$) { 316 | my ($url, $allow_html, $cb) = @_; 317 | 318 | $cv->begin; 319 | http_head $url, sub { 320 | my ($data, $headers) = @_; 321 | my $content_type = $headers->{'content-type'} || ''; 322 | 323 | if ($headers->{'Status'} == 200 && ( 324 | $content_type ne 'text/html' || $allow_html)) { 325 | &$cb(1); 326 | } else { 327 | &$cb(0); 328 | } 329 | $cv->end; 330 | }; 331 | } 332 | 333 | sub callback_return($) { 334 | my $cb = shift; 335 | 336 | &$cb(1); 337 | 338 | return 1; 339 | } 340 | 341 | sub test_arch($$$$) { 342 | my ($base_url, $type, $arch, $cb) = @_; 343 | my $format; 344 | 345 | return test_source($base_url, $type, $cb) if ($arch eq 'source'); 346 | 347 | if ($type eq 'archive') { 348 | $format = 'indices/files/arch-%s.files'; 349 | } elsif ($type eq 'backports') { 350 | $format = 'dists/oldoldstable-backports/main/binary-%s/Release'; 351 | } elsif ($type eq 'ports') { 352 | $format = 'dists/sid/main/binary-%s/Release'; 353 | } elsif ($type eq 'security') { 354 | $format = 'dists/stable/updates/main/binary-%s/Packages.gz'; 355 | } else { 356 | # unknown/unsupported type 357 | return callback_return($cb); 358 | } 359 | 360 | # FIXME: we should really check more than just the standard 361 | $arch = 'i386' if ($arch eq 'any'); 362 | 363 | my $url = $base_url; 364 | $url .= sprintf($format, $arch); 365 | 366 | head_url($url, 0, $cb); 367 | } 368 | 369 | sub test_source($$$) { 370 | my ($base_url, $type, $cb) = @_; 371 | my $format; 372 | 373 | if ($type eq 'archive') { 374 | $format = 'dists/sid/main/source/Release'; 375 | } elsif ($type eq 'backports') { 376 | $format = 'dists/oldoldstable-backports/main/source/Release'; 377 | } elsif ($type eq 'ports') { 378 | # no sources for ports 379 | return callback_return($cb); 380 | } elsif ($type eq 'security') { 381 | $format = 'dists/stable/updates/main/source/Sources.gz'; 382 | } else { 383 | # unknown/unsupported type 384 | return callback_return($cb); 385 | } 386 | 387 | my $url = $base_url . $format; 388 | 389 | head_url($url, 0, $cb); 390 | } 391 | 392 | sub test_areas($$$) { 393 | my ($base_url, $type, $cb) = @_; 394 | my $format; 395 | my @areas = qw(main contrib non-free); 396 | 397 | if ($type eq 'archive') { 398 | $format = 'dists/sid/%s/'; 399 | } elsif ($type eq 'backports') { 400 | $format = 'dists/oldoldstable-backports/%s/'; 401 | } elsif ($type eq 'ports') { 402 | # only main for ports 403 | @areas = qw(main); 404 | $format = 'dists/sid/%s/'; 405 | } elsif ($type eq 'security') { 406 | $format = 'dists/stable/updates/%s/'; 407 | } else { 408 | # unknown/unsupported type 409 | return callback_return($cb); 410 | } 411 | 412 | my $remaining_areas = scalar(@areas); 413 | for my $area (@areas) { 414 | my $url = $base_url; 415 | $url .= sprintf($format, $area); 416 | 417 | $cv->begin; 418 | head_url($url, 1, sub { 419 | my $success = shift; 420 | 421 | # Used to only call the cb once 422 | if ($remaining_areas < 0) { 423 | $cv->end; 424 | return; 425 | } 426 | if (!$success) { 427 | &$cb(0); 428 | $remaining_areas = -1; 429 | } 430 | if (--$remaining_areas == 0) { 431 | &$cb(1); 432 | } 433 | $cv->end; 434 | }); 435 | } 436 | } 437 | 438 | sub test_stages($$$$) { 439 | my ($base_url, $type, $master_trace, $cb) = @_; 440 | my $format; 441 | 442 | if ($type eq 'archive') { 443 | $format = 'dists/sid/Release'; 444 | } elsif ($type eq 'backports') { 445 | $format = 'dists/oldoldstable-backports/Release'; 446 | } elsif ($type eq 'ports') { 447 | $format = 'dists/sid/Release'; 448 | } elsif ($type eq 'security') { 449 | $format = 'dists/stable/updates/Release'; 450 | } else { 451 | # unknown/unsupported type, say we succeeded 452 | return callback_return($cb); 453 | } 454 | 455 | my $url = $base_url . $format; 456 | my $trace_date = HTTP::Date::time2str($master_trace->date); 457 | 458 | $cv->begin; 459 | http_head $url, 460 | headers => ('if-unmodified-since' => $trace_date), 461 | sub { 462 | my ($data, $headers) = @_; 463 | # The last-modified date of $url should never be newer than the one 464 | # in the trace file. Use if-unmodified-since so that a 412 code is 465 | # returned on failure, and a 200 if successful (or if the server 466 | # ignored the if-unmodified-since) 467 | &$cb($headers->{'Status'} == 200 || $headers->{'Status'} == 500); 468 | $cv->end; 469 | } 470 | ; 471 | } 472 | 473 | sub archs_by_mirror($$) { 474 | my ($id, $type) = @_; 475 | 476 | # Find the list of architectures supposedly included by the 477 | # given mirror. Traverse the inverted indexes to determine them 478 | my @all_archs = keys %{$db->{$type}{'arch'}}; 479 | my @archs; 480 | for my $arch (@all_archs) { 481 | next unless (exists($db->{$type}{'arch'}{$arch}{$id})); 482 | push @archs, $arch; 483 | } 484 | return @archs; 485 | } 486 | 487 | sub mirror_types_to_check($) { 488 | my $id = shift; 489 | my $mirror = $db->{'all'}{$id}; 490 | my @mirror_types; 491 | my @types_to_check; 492 | 493 | for my $k (keys %$mirror) { 494 | next unless ($k =~ m/^(.+)-http$/); 495 | push @mirror_types, $1; 496 | } 497 | 498 | for my $type (@mirror_types) { 499 | next if (exists($mirror->{$type.'-tracearchcheck-disabled'}) && !$check_trace_archs); 500 | next if (exists($mirror->{$type.'-archcheck-disabled'}) && !$check_archs); 501 | next if (exists($mirror->{$type.'-areascheck-disabled'}) && !$check_areas); 502 | next if (exists($mirror->{$type.'-file-disabled'}) && !$disable_sites); 503 | # There's no way back for this one: 504 | next if (exists($mirror->{$type.'-stages-disabled'})); 505 | 506 | if ($disable_sites) { 507 | my $todisable = $sites_to_disable{$mirror->{'site'}}; 508 | my $disabled = exists($mirror->{$type.'-file-disabled'}); 509 | 510 | if (exists($todisable->{$type}) || exists($todisable->{'any'})) { 511 | disable_mirrors($type, $disabled? '' : "blacklisted", $id); 512 | $mirror->{$type.'-file-disabled'} = undef; 513 | next; 514 | } else { 515 | log_message($id, $type, "no longer blacklisted") 516 | if ($disabled); 517 | delete $mirror->{$type.'-file-disabled'}; 518 | } 519 | } 520 | push @types_to_check, $type; 521 | } 522 | 523 | return @types_to_check; 524 | } 525 | 526 | sub check_mirror($$) { 527 | my $id = shift; 528 | my $type = shift; 529 | 530 | my $mtrace_content = ''; 531 | my $mirror = $db->{'all'}{$id}; 532 | my $master_trace; 533 | my $base_url = 'http://'.$mirror->{'site'}.$mirror->{$type.'-http'}; 534 | 535 | $mirror->{$type.'-rtltr'} = undef 536 | unless (exists($mirror->{$type.'-rtltr'})); 537 | my $rtltr = Mirror::RateLimiter->load(\$mirror->{$type.'-rtltr'}); 538 | 539 | return if ($rtltr->should_skip); 540 | $master_trace = Mirror::Trace->new($base_url); 541 | 542 | delete $mirror->{$type.'-badmaster'}; 543 | delete $mirror->{$type.'-badsubset'}; 544 | 545 | $cv->begin; 546 | http_get $master_trace->get_url($db->{$type}{'master'}), 547 | on_body => sub {store_not_too_much(shift, \$mtrace_content, shift->{'Status'})}, 548 | sub { 549 | my ($empty, $headers) = @_; 550 | if ($headers->{'Status'} != 200 || !$master_trace->from_string($mtrace_content)) { 551 | my $error = ($headers->{'Status'} != 200)? $headers->{'Reason'} : 'parse error'; 552 | disable_mirrors($type, "bad master trace ($error)", $id); 553 | $mirror->{$type.'-badmaster'} = undef; 554 | $rtltr->record_failure; 555 | #if (fatal_connection_error($error)) { abort remaining connections } 556 | } else { 557 | my $site_trace = Mirror::Trace->new($base_url); 558 | my $strace_content = ''; 559 | 560 | delete $mirror->{$type.'-badsite'}; 561 | delete $mirror->{$type.'-oldftpsync'}; 562 | delete $mirror->{$type.'-oldsite'}; 563 | delete $mirror->{$type.'-notinrelease'}; 564 | delete $mirror->{$type.'-noti18n'}; 565 | 566 | $cv->begin; 567 | http_get $site_trace->get_url($mirror->{'trace-file'} || $mirror->{'site'}), 568 | on_body => sub {store_not_too_much(shift, \$strace_content, shift->{'Status'})}, 569 | sub { 570 | my ($empty, $headers) = @_; 571 | if ($headers->{'Status'} != 200 || !$site_trace->from_string($strace_content)) { 572 | my $error = ($headers->{'Status'} != 200)? $headers->{'Reason'} : 'parse error'; 573 | $mirror->{$type.'-badsite'} = undef; 574 | disable_mirrors($type, "bad site trace ($error)", $id); 575 | $rtltr->record_failure; 576 | #if (fatal_connection_error($error)) { abort remaining connections } 577 | } else { 578 | my %httpd_features = ('keep-alive' => 0, 'ranges' => 0); 579 | if ($headers->{'connection'}) { 580 | $httpd_features{'keep-alive'} = ($headers->{'connection'} =~ /^keep-alive$/i); 581 | } else { 582 | $httpd_features{'keep-alive'} = ($headers->{'HTTPVersion'} eq '1.1'); 583 | } 584 | if ($headers->{'accept-ranges'}) { 585 | $httpd_features{'ranges'} = ($headers->{'accept-ranges'} =~ /^bytes$/i ); 586 | } 587 | 588 | while (my ($k, $v) = each %httpd_features) { 589 | next if (exists($mirror->{$type.'-'.$k}) eq $v); 590 | 591 | if (exists($mirror->{$type.'-'.$k})) { 592 | log_message($id, $type, "No more http/$k"); 593 | delete $mirror->{$type.'-'.$k}; 594 | } else { 595 | log_message($id, $type, "http/$k support seen"); 596 | $mirror->{$type.'-'.$k} = undef; 597 | } 598 | } 599 | check_mirror_post_master($id, $type, $rtltr, $master_trace, $site_trace); 600 | } 601 | $cv->end; 602 | } 603 | ; 604 | 605 | if ($check_2stages) { 606 | test_stages($base_url, $type, $master_trace, sub { 607 | my $success = shift; 608 | if (!$success) { 609 | disable_mirrors($type, "doesn't perform 2stages sync", $id); 610 | $mirror->{$type.'-stages-disabled'} = undef; 611 | $rtltr->record_failure; 612 | } 613 | }); 614 | } 615 | } 616 | $cv->end; 617 | } 618 | ; 619 | 620 | if ($check_areas) { 621 | delete $mirror->{$type.'-areascheck-disabled'}; 622 | test_areas($base_url, $type, sub { 623 | my $success = shift; 624 | if (!$success) { 625 | disable_mirrors($type, "missing areas", $id); 626 | $mirror->{$type.'-areascheck-disabled'} = undef; 627 | $rtltr->record_failure; 628 | } 629 | }); 630 | } 631 | } 632 | 633 | sub check_mirror_post_master($$$$$) { 634 | my $id = shift; 635 | my $type = shift; 636 | my $rtltr = shift; 637 | my $mirror = $db->{'all'}{$id}; 638 | my $base_url = 'http://'.$mirror->{'site'}.$mirror->{$type.'-http'}; 639 | 640 | { 641 | my $master_trace = shift; 642 | my $site_trace = shift; 643 | my $disable_reason; 644 | my $ignore_master = 0; 645 | 646 | my $stored_site_date = $mirror->{$type.'-site'} || 0; 647 | my $stored_master_date = $mirror->{$type.'-master'} || 0; 648 | 649 | if ($site_trace->date < $master_trace->date) { 650 | $ignore_master = 1; 651 | $disable_reason = 'old site trace'; 652 | $mirror->{$type.'-oldsite'} = undef; 653 | } elsif (!$site_trace->uses_ftpsync) { 654 | log_message($id, $type, "doesn't use ftpsync"); 655 | } elsif (!$site_trace->good_ftpsync) { 656 | $disable_reason = 'old ftpsync'; 657 | $mirror->{$type.'-oldftpsync'} = undef; 658 | $rtltr->record_failure; 659 | } 660 | 661 | 662 | unless ($disable_reason) { 663 | # Similar to the site->date < $master->date check above 664 | # but stricter. Only accept a master bump if the site 665 | # is also updated. 666 | if ($master_trace->date > $stored_master_date && 667 | $site_trace->date == $stored_site_date) { 668 | $ignore_master = 1; 669 | $disable_reason = 'new master but no new site'; 670 | $mirror->{$type.'-oldsite'} = undef; 671 | } else { 672 | # only update them when in an accepted state: 673 | $mirror->{$type.'-site'} = $site_trace->date; 674 | $mirror->{$type.'-master'} = $master_trace->date; 675 | } 676 | 677 | if (!$site_trace->features('inrelease')) { 678 | log_message($id, $type, "doesn't handle InRelease files correctly") 679 | if ($verbose); 680 | $mirror->{$type.'-notinrelease'} = undef; 681 | } 682 | if (!$site_trace->features('i18n')) { 683 | log_message($id, $type, "doesn't handle i18n files correctly") 684 | if ($verbose); 685 | $mirror->{$type.'-noti18n'} = undef; 686 | } 687 | if ($site_trace->features('architectures')) { 688 | if ($check_trace_archs) { 689 | delete $mirror->{$type.'-tracearchcheck-disabled'}; 690 | 691 | my @archs = archs_by_mirror($id, $type); 692 | for my $arch (@archs) { 693 | if ($arch eq 'any' && $site_trace->arch('GUESSED')) { 694 | # not much can be done about it 695 | next; 696 | } 697 | if (!$site_trace->arch($arch)) { 698 | # Whenever disabling an arch because it 699 | # isn't listed in the site's trace file, 700 | # always require this check to be performed 701 | # before re-enabling the arch 702 | $mirror->{$type.'-'.$arch.'-trace-disabled'} = undef; 703 | $mirror->{$type.'-'.$arch.'-disabled'} = undef; 704 | log_message($id, $type, "missing $arch (det. from trace file)"); 705 | } elsif (exists($mirror->{$type.'-'.$arch.'-trace-disabled'})) { 706 | log_message($id, $type, "re-enabling $arch (det. from trace file)"); 707 | delete $mirror->{$type.'-'.$arch.'-disabled'}; 708 | delete $mirror->{$type.'-'.$arch.'-trace-disabled'}; 709 | } 710 | } 711 | 712 | if (!exists($db->{$type}{'arch'}{'source'}) && !$site_trace->arch('source')) { 713 | $rtltr->record_failure; 714 | $mirror->{$type.'-tracearchcheck-disabled'} = undef; 715 | $disable_reason = "no sources (det. from trace file)"; 716 | } 717 | } 718 | } else { 719 | log_message($id, $type, "doesn't list architectures"); 720 | } 721 | } 722 | 723 | if (!$ignore_master) { 724 | $traces{$type} = {} 725 | unless (exists($traces{$type})); 726 | $traces{$type}{$master_trace->date} = [] 727 | unless (exists($traces{$type}{$master_trace->date})); 728 | push @{$traces{$type}{$master_trace->date}}, $id; 729 | } 730 | 731 | if ($disable_reason) { 732 | disable_mirrors($type, $disable_reason, $id); 733 | } elsif (exists($mirror->{$type.'-disabled'}) && !disabled_this_session($type, $id)) { 734 | log_message($id, $type, "re-considering, good traces"); 735 | delete $mirror->{$type.'-disabled'} 736 | if ($process_stamps); 737 | } 738 | } 739 | 740 | if ($check_archs) { 741 | my $sticky_archcheck_flag = 0; 742 | if (!exists($db->{$type}{'arch'}{'source'})) { 743 | test_source($base_url, $type, sub { 744 | my $success = shift; 745 | if (!$success) { 746 | disable_mirrors($type, "no sources", $id); 747 | $mirror->{$type.'-archcheck-disabled'} = undef; 748 | # Prevent any other callback (below) from dropping 749 | # the flag 750 | $sticky_archcheck_flag = 1; 751 | } 752 | }); 753 | } 754 | 755 | my @archs = archs_by_mirror($id, $type); 756 | # By default assume that all architectures are missing 757 | $mirror->{$type.'-archcheck-disabled'} = undef; 758 | for my $arch (@archs) { 759 | # Don't even check it if it was disabled because the 760 | # trace file says it is not included 761 | next if (exists($mirror->{$type.'-'.$arch.'-trace-disabled'})); 762 | 763 | test_arch($base_url, $type, $arch, sub { 764 | my $success = shift; 765 | if (!$success) { 766 | $mirror->{$type.'-'.$arch.'-disabled'} = undef; 767 | log_message($id, $type, "missing $arch"); 768 | } else { 769 | log_message($id, $type, "re-enabling $arch") 770 | if (exists($mirror->{$type.'-'.$arch.'-disabled'})); 771 | delete $mirror->{$type.'-'.$arch.'-disabled'}; 772 | delete $mirror->{$type.'-archcheck-disabled'} 773 | unless ($sticky_archcheck_flag); 774 | } 775 | }); 776 | } 777 | } 778 | } 779 | 780 | sub log_message($$$) { 781 | my ($id, $type, $msg) = @_; 782 | 783 | print "[$id/$type] $msg\n"; 784 | } 785 | 786 | sub parse_disable_file($) { 787 | my $disable_file = shift; 788 | my %disable_index; 789 | 790 | open(my $fh, '<', $disable_file) or 791 | die "warning: could not open '$disable_file' for reading\n"; 792 | 793 | while (<$fh>) { 794 | next if (m/^\s*$/); 795 | next if (m/^\s*#/); 796 | chomp; 797 | 798 | my @parts = split(qr, $_, 3); 799 | if (scalar(@parts) == 3) { 800 | warn "warning: malformed input (should be 'site[/type]')"; 801 | next; 802 | } 803 | 804 | unless (exists($disable_index{$parts[0]})) { 805 | $disable_index{$parts[0]} = {}; 806 | } 807 | if (defined($parts[1])) { 808 | $disable_index{$parts[0]}{$parts[1]} = 1; 809 | } else { 810 | $disable_index{$parts[0]}{'any'} = 1; 811 | } 812 | } 813 | close ($fh); 814 | return \%disable_index; 815 | } 816 | 817 | sub fatal_connection_error($) { 818 | my $error = shift; 819 | 820 | # 598: 'user aborted request via "on_header" or "on_body".' 821 | return ($error =~ m/^59/ && $error != 598); 822 | } 823 | 824 | sub disable_mirrors($$@) { 825 | my ($type, $reason) = (shift, shift); 826 | my @mirrors = @_; 827 | 828 | while (defined(my $id = pop @mirrors)) { 829 | $db->{'all'}{$id}{$type.'-disabled'} = undef; 830 | $just_disabled{"$id:$type"} = 1; 831 | log_message($id, $type, $reason) if ($reason); 832 | } 833 | } 834 | 835 | sub mark_bad_subset($$@) { 836 | my ($type, $reason) = (shift, shift); 837 | my @mirrors = @_; 838 | 839 | disable_mirrors($type, $reason, @mirrors); 840 | while (defined(my $id = pop @mirrors)) { 841 | $db->{'all'}{$id}{$type.'-badsubset'} = undef; 842 | } 843 | } 844 | 845 | sub mirror_provides_arch($$$) { 846 | my ($id, $type, $arch) = @_; 847 | 848 | my $mirror = $db->{'all'}{$id}; 849 | 850 | if (exists($db->{$type}{'arch'}{$arch}) && exists($db->{$type}{'arch'}{$arch}{$id}) 851 | && !exists($mirror->{$type.'-'.$arch.'-disabled'})) { 852 | return 1; 853 | } 854 | return 0; 855 | } 856 | 857 | sub store_not_too_much($$$) { 858 | my ($data, $store, $status) = @_; 859 | 860 | if ($status != 200) { 861 | $$store = 0 862 | if ($$store eq ''); 863 | $$store += length($data); 864 | 865 | if ($$store > 1024*2) { 866 | $$store = undef; 867 | return 0; 868 | } 869 | return 1; 870 | } 871 | 872 | $$store .= $data; 873 | if (length($$store) > 1024) { 874 | $$store = undef; 875 | # abort the connection 876 | return 0; 877 | } 878 | return 1; 879 | } 880 | 881 | sub disabled_this_session($$) { 882 | my ($type, $id) = @_; 883 | return exists($just_disabled{"$id:$type"}); 884 | } 885 | -------------------------------------------------------------------------------- /demo.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Demonstration - Debian mirrors HTTP redirector 5 | 6 | 7 | 8 | 9 |

Demonstration

10 | 71 | 75 |
76 |

77 | Your details, as seen by the redirector: 78 |

79 | 82 |
83 |
84 |
85 |
86 |
87 |
88 |
89 |

90 | Had you requested a file to /debian/, 91 | you would have been sent to one of the following mirrors: 92 |

93 | 96 |
97 |
98 |
99 |
100 | | 101 | 108 |
109 |

Explanation

110 |

111 | The destination mirrors depends on many factors, from those mentioned 112 | above, to the reachability, freshness, etc.
113 | The population may be bigger than the number of mirrors listed 114 | above, meaning there were other candidates but they were not considered 115 | because of their distance to you. 116 |

117 |
118 |
119 |

Corrections and issue reporting

120 |

121 | If any of the fields of the your details section is incorrect, 122 | please refer to maxmind.com. If your 124 | details are correct there, then it might be a limitation of the free 125 | version of their database. Otherwise, feel free to send them a correction.
127 | If you believe there's another mirror that could serve you better, 128 | other than those listed above, please check the following before 129 | contacting me (it's not mandatory, but you would save me some time): 130 |

131 |
    132 |
  1. Make sure it is part of the official Debian mirrors 134 | network
    2. 135 |
  2. It is up to date (the main archive is updated several times a day)
    3. 136 |
  3. There's a file with the same name as the mirror's host name in the 137 | project/trace/ directory (e.g. 138 | http://mirror.tld/debian/project/trace/mirror.tld)
    4. 139 |
140 |

141 | All three points can be fixed by the mirror administrators, and only by 142 | them.
143 | At some point there will be a page where you can check why a mirror is 144 | disabled in the redirector.
145 | If after all that, there's a mirror that would serve you better and it 146 | isn't listed, please do send me an email along with the 148 | response headers to the email address at the bottom of this page. 149 | 151 |

152 |
153 | 162 | 163 | 164 | -------------------------------------------------------------------------------- /dump-db.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Storable qw(retrieve); 6 | use Data::Dumper; 7 | 8 | $Data::Dumper::Purity = 1; 9 | 10 | my $db = 'db'; 11 | 12 | $db = $ARGV[0] if (defined($ARGV[0])); 13 | 14 | print Dumper(retrieve($db)); 15 | -------------------------------------------------------------------------------- /extract-peers.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | #################### 4 | # Copyright (C) 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Getopt::Long; 27 | 28 | my $print_progress = 0; 29 | my $max_distance = 1; 30 | my $output_file = 'peers.lst.d/routing-table.lst'; 31 | 32 | GetOptions('progress!' => \$print_progress, 33 | 'distance=i' => \$max_distance, 34 | 'output-file=s' => \$output_file) or exit 1; 35 | 36 | my $count = -1; 37 | 38 | $count = 0 if ($print_progress); 39 | 40 | sub seen; 41 | 42 | my $out; 43 | 44 | if ($output_file eq '-') { 45 | $out = \*STDOUT; 46 | } else { 47 | open($out, '>', $output_file) 48 | or die("error: could not open '$output_file' for writing: $!\n"); 49 | } 50 | 51 | print $out "# AS peering table\n"; 52 | print $out "# Using a maximum distance of $max_distance\n"; 53 | 54 | while (<>) { 55 | my @parts = split; 56 | next unless (scalar(@parts) >= 3); 57 | 58 | my @dests = pop @parts; 59 | # get rid of the network mask 60 | my $address = shift @parts; 61 | my $ipv = ($address =~ m/:/)? 'v6' : 'v4'; 62 | 63 | if ($dests[0] =~ s/^\{// && $dests[0] =~ s/\}$//) { 64 | @dests = split (/,/, $dests[0]); 65 | } 66 | 67 | for my $dest (@dests) { 68 | my $distance = 0; 69 | 70 | my @path = @parts; 71 | while (my @peers = pop @path) { 72 | last unless ($distance < $max_distance); 73 | $distance++; 74 | 75 | if ($peers[0] =~ s/^\{// && $peers[0] =~ s/\}$//) { 76 | @peers = split (/,/, $peers[0]); 77 | } 78 | while (my $peer = pop @peers) { 79 | next if ($dest eq $peer); 80 | my $output = "$dest $peer $distance $ipv"; 81 | 82 | print $out "$output\n" if (not seen($output)); 83 | } 84 | } 85 | } 86 | 87 | if ($count != -1 && ($count++)%1000 == 0) { 88 | print STDERR "Processed: $count...\r"; 89 | } 90 | } 91 | 92 | my %seen_cache_index; 93 | my @seen_cache; 94 | sub seen { 95 | my $entry = shift; 96 | 97 | return 1 if (exists($seen_cache_index{$entry})); 98 | 99 | # cache up to 3 items 100 | if (scalar(@seen_cache) == 3) { 101 | delete $seen_cache_index{shift @seen_cache}; 102 | } 103 | 104 | push @seen_cache, $entry; 105 | $seen_cache_index{$entry} = undef; 106 | return 0; 107 | } 108 | -------------------------------------------------------------------------------- /import-dump.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Getopt::Long; 6 | 7 | use lib '.'; 8 | use Mirror::DB; 9 | 10 | my $db_output = 'db'; 11 | my $file = undef; 12 | 13 | GetOptions('db-output=s' => \$db_output, 14 | 'dump-file=s' => \$file) or exit 1; 15 | 16 | $file = $db_output.'.dump' if (!defined($file)); 17 | 18 | our $VAR1; 19 | 20 | die ("failed to import '$file'") unless (do $file); 21 | 22 | Mirror::DB::set($db_output); 23 | Mirror::DB::store($VAR1); 24 | -------------------------------------------------------------------------------- /local-request.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Plack::Test; 7 | use HTTP::Request::Common; 8 | 9 | use Mirror::Redirector; 10 | 11 | my $app = Mirror::Redirector->new; 12 | 13 | my $params = $ARGV[0] || ''; 14 | 15 | $app->set_local_ip($ENV{'REMOTE_ADDR'}) 16 | if (defined($ENV{'REMOTE_ADDR'})); 17 | 18 | test_psgi app => sub { $app->run(@_) }, client => sub { 19 | my $cb = shift; 20 | my $res = $cb->(GET "/?action=demo&$params"); 21 | print $res->as_string; 22 | }; 23 | -------------------------------------------------------------------------------- /mirrors.lst.d/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rgeissert/http-redirector/243b95a345dd67992904b1f98ebbff1b70cf3806/mirrors.lst.d/.gitkeep -------------------------------------------------------------------------------- /peers.lst.d/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rgeissert/http-redirector/243b95a345dd67992904b1f98ebbff1b70cf3806/peers.lst.d/.gitkeep -------------------------------------------------------------------------------- /t/Mirror/AS/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { use_ok('Mirror::AS'); } 8 | -------------------------------------------------------------------------------- /t/Mirror/AS/01-convert.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | use Mirror::AS; 8 | 9 | is(Mirror::AS::convert(1), 1, 'AS 1 converts to 1'); 10 | is(Mirror::AS::convert(2.1005), 132077, 'AS 2.1005 converts to 132077'); 11 | 12 | is(Mirror::AS::convert("AS1"), 1, '"AS1" converts to 1'); 13 | -------------------------------------------------------------------------------- /t/Mirror/CountryCoords/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { 8 | use_ok('Mirror::CountryCoords'); 9 | } 10 | -------------------------------------------------------------------------------- /t/Mirror/CountryCoords/01-coords-for-country.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 6; 6 | 7 | use Mirror::CountryCoords; 8 | 9 | can_ok('Mirror::CountryCoords', 'country'); 10 | 11 | ok(Mirror::CountryCoords::country('FR'), 'Can lookup coords of FR'); 12 | is_deeply(Mirror::CountryCoords::country('FR'), 13 | {'lat' => '46.0000', 'lon' => '2.0000'}, 'Coords of FR'); 14 | 15 | ok(Mirror::CountryCoords::country('DE'), 'Can lookup coords of DE'); 16 | is_deeply(Mirror::CountryCoords::country('DE'), 17 | {'lat' => '51.0000', 'lon' => '9.0000'}, 'Coords of DE'); 18 | 19 | is(Mirror::CountryCoords::country('XX'), undef, 'No known country results in undef'); 20 | -------------------------------------------------------------------------------- /t/Mirror/DB/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { use_ok('Mirror::DB'); } 8 | -------------------------------------------------------------------------------- /t/Mirror/DB/01-store.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | use Mirror::DB; 8 | 9 | Mirror::DB::set('db.test'); 10 | ok(Mirror::DB::store(\'something'), 'store'); #' 11 | unlink('db.test'); 12 | -------------------------------------------------------------------------------- /t/Mirror/DB/02-store-shared.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | use threads; 8 | use threads::shared; 9 | use Mirror::DB; 10 | use Storable qw(retrieve); 11 | 12 | Mirror::DB::set('db.test'); 13 | 14 | my $db :shared = shared_clone([]); 15 | 16 | ok(Mirror::DB::store($db), 'store shared'); 17 | 18 | is_deeply($db, [], 'db is (a ref to) an empty array'); 19 | 20 | my $sdb = retrieve('db.test'); 21 | 22 | eval { is_deeply($db, $sdb, 'db and its stored version are equal'); } 23 | or fail('could not compare db to its stored version'); 24 | 25 | unlink('db.test'); 26 | -------------------------------------------------------------------------------- /t/Mirror/Fake/Geoip/Record/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { 8 | use_ok('Mirror::Fake::Geoip::Record'); 9 | } 10 | -------------------------------------------------------------------------------- /t/Mirror/Fake/Geoip/Record/01-set-and-get.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 9; 6 | 7 | use Mirror::Fake::Geoip::Record; 8 | 9 | can_ok('Mirror::Fake::Geoip::Record', 'new'); 10 | 11 | my $geoip_rec; 12 | eval { 13 | $geoip_rec = Mirror::Fake::Geoip::Record->new( 14 | latitude => '52.5', 15 | longitude => '5.75', 16 | country_code => 'NL', 17 | continent_code => 'EU', 18 | ); 19 | }; is($@, '', 'Creating a fake geoip record failed'); 20 | 21 | can_ok($geoip_rec, qw(latitude longitude country_code continent_code)); 22 | is($geoip_rec->latitude, '52.5', 'Can get the lat back'); 23 | is($geoip_rec->longitude, '5.75', 'Can get the lon back'); 24 | is($geoip_rec->country_code, 'NL', 'Can get the country back'); 25 | is($geoip_rec->continent_code, 'EU', 'Can get the continent back'); 26 | is($geoip_rec->city, '', 'city is empty'); 27 | is($geoip_rec->region, '', 'region is empty'); 28 | -------------------------------------------------------------------------------- /t/Mirror/FallbackGeoLocation/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { 8 | use_ok('Mirror::FallbackGeoLocation'); 9 | } 10 | -------------------------------------------------------------------------------- /t/Mirror/FallbackGeoLocation/01-get_record.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | use Storable qw(retrieve); 8 | use Mirror::FallbackGeoLocation; 9 | 10 | my $db; 11 | eval { 12 | $db = retrieve('db'); 13 | plan tests => 3; 14 | }; 15 | if ($@) { 16 | plan skip_all => "Failed to retrieve db: $@"; 17 | exit; 18 | } 19 | 20 | can_ok('Mirror::FallbackGeoLocation', 'get_record'); 21 | 22 | ok(Mirror::FallbackGeoLocation::get_record($db, 'archive'), 'Can get a record'); 23 | my $rec = Mirror::FallbackGeoLocation::get_record($db, 'archive'); 24 | 25 | can_ok($rec, qw(city continent_code country_code latitude longitude region)); 26 | -------------------------------------------------------------------------------- /t/Mirror/FallbackGeoLocation/02-caching.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | use Storable qw(retrieve); 8 | use Mirror::FallbackGeoLocation; 9 | 10 | my $db; 11 | eval { 12 | $db = retrieve('db'); 13 | plan tests => 3; 14 | }; 15 | if ($@) { 16 | plan skip_all => "Failed to retrieve db: $@"; 17 | exit; 18 | } 19 | 20 | my $rec1; 21 | 22 | ok($rec1 = Mirror::FallbackGeoLocation::get_record($db, 'archive'), 'Can get a record'); 23 | 24 | # The lookup should now be in the cache 25 | $db = undef; 26 | 27 | my $rec2 = Mirror::FallbackGeoLocation::get_record($db, 'archive'); 28 | can_ok($rec2, qw(city continent_code country_code latitude longitude region)); 29 | 30 | is_deeply($rec1, $rec2, 'The two records should be equal'); 31 | -------------------------------------------------------------------------------- /t/Mirror/Math/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { use_ok('Mirror::Math'); } 8 | -------------------------------------------------------------------------------- /t/Mirror/Math/01-stddev.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | use Mirror::Math; 8 | 9 | is(Mirror::Math::stddev(1, 1, 1), 0, 'stddev of equals is 0'); 10 | is(Mirror::Math::stddev(1, 2, 3), 1, 'stddev of 1, 2, and 3 is 1'); 11 | 12 | eval { is(Mirror::Math::stddev(7), 0, 'stddev of one element is 0'); 13 | } or fail ($@); 14 | -------------------------------------------------------------------------------- /t/Mirror/Math/01-stddevp.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use Mirror::Math; 8 | 9 | is(Mirror::Math::stddevp(1, 1, 1), 0, 'stddev of equals is 0'); 10 | is(Mirror::Math::stddevp(1, -1), 1, 'stddevp of 1 and -1 is 1'); 11 | -------------------------------------------------------------------------------- /t/Mirror/Math/02-distance.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 6; 6 | 7 | use Mirror::Math; 8 | 9 | is($Mirror::Math::METRIC, 'taxicab', 'default metric is taxicab'); 10 | is(Mirror::Math::calculate_distance(0, 0, 0, 0), 0, 'distance from (0,0) is (0,0)'); 11 | is(Mirror::Math::calculate_distance(0, 1, 1, 0), 2, '(0, 1) to (1, 0) in taxicab is 2'); 12 | 13 | ok(Mirror::Math::set_metric('euclidean'), 'can set metric to euclidean'); 14 | is(Mirror::Math::calculate_distance(0, 0, 0, 0), 0, 'distance from (0,0) is (0,0)'); 15 | is(Mirror::Math::calculate_distance(0, 0, 3, 0), 3, '(0, 0) to (3, 0) in euclidean is 3'); 16 | -------------------------------------------------------------------------------- /t/Mirror/Math/03-stddev-precision.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | use Mirror::Math; 8 | 9 | my $d = Mirror::Math::calculate_distance('2.0000', '46.0000', '1.4333', '43.6000'); 10 | 11 | eval { 12 | is(Mirror::Math::stddevp($d, $d, $d, $d, $d, $d), 0, 'stddev six times $d is 0'); 13 | } or fail($@); 14 | -------------------------------------------------------------------------------- /t/Mirror/Math/04-quartiles.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | use Mirror::Math; 8 | 9 | my @inter_iquartile = Mirror::Math::iquartile(qw(3 3 6 7 7 10 10 10 11 13 30)); 10 | 11 | is(join (',', @inter_iquartile), '6,7,7,10,10,10,11', 'inter quartile values'); 12 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 1; 7 | 8 | use_ok('Mirror::RateLimiter'); 9 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/01-new.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | eval { 13 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 14 | } or fail($@); 15 | pass('Can create a new Mirror::RateLimiter'); 16 | 17 | isa_ok($rtltr, 'Mirror::RateLimiter'); 18 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/02-skip.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 13 | 14 | can_ok($rtltr, 'should_skip'); 15 | ok(!$rtltr->should_skip, 'We should not skip, there has been no failure'); 16 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/03-tolerance.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 9; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 13 | 14 | is($rtltr->attempts, 0, '0 attempts so far'); 15 | ok(!$rtltr->should_skip, 'We should not skip, there has been no failure'); 16 | 17 | $rtltr->record_failure; 18 | 19 | # Save the status, to allow the object to be reused 20 | can_ok($rtltr, 'save'); 21 | $rtltr->save; 22 | 23 | # Allow a one-time failure tolerance 24 | is($rtltr->attempts, 1, '1 attempt'); 25 | ok(!$rtltr->should_skip, 'We should not skip, there has been only one failure'); 26 | 27 | $rtltr->record_failure; 28 | $rtltr->save; 29 | 30 | is($rtltr->attempts, 2, '2 attempts'); 31 | ok($rtltr->should_skip, 'We should skip, there have been two failures'); 32 | $rtltr->save; 33 | 34 | is($rtltr->attempts, 3, '3 attempts'); 35 | ok(!$rtltr->should_skip, 'We should no longer skip, we skipped once already'); 36 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/04-load-store-load.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 14; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 13 | 14 | can_ok($rtltr, 'record_failure'); 15 | can_ok($rtltr, 'attempts'); 16 | 17 | is($rtltr->attempts, 0, 'No attempt has been recorded'); 18 | ok(!$rtltr->should_skip, 'Therefore, we should not skip'); 19 | is($rtltr->attempts, 1, 'Now one attempt has been recorded'); 20 | 21 | $rtltr->record_failure; 22 | 23 | 24 | # Explicit save before re-loading state 25 | $rtltr->save; 26 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 27 | is($rtltr->attempts, 1, 'One attempt has been recorded'); 28 | ok(!$rtltr->should_skip, 'We should not skip, this is the second attempt'); 29 | is($rtltr->attempts, 2, 'Two attempts have been recorded'); 30 | 31 | $rtltr->record_failure; 32 | 33 | 34 | # [again] Explicit save before re-loading state 35 | $rtltr->save; 36 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 37 | is($rtltr->attempts, 2, 'Two attempts have been recorded'); 38 | ok($rtltr->should_skip, 'We should skip, this is the third attempt'); 39 | is($rtltr->attempts, 3, 'Three attempts have been recorded'); 40 | 41 | 42 | # [again] Explicit save before re-loading state 43 | $rtltr->save; 44 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 45 | is($rtltr->attempts, 3, 'Three attempts have been recorded'); 46 | ok(!$rtltr->should_skip, 'We should not skip, this is the fourth attempt'); 47 | is($rtltr->attempts, 4, 'Four attempts have been recorded'); 48 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/05-failure-attempts-ratio.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 7; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 13 | 14 | ok(!$rtltr->should_skip, 'We should not skip, there has been no failure'); 15 | $rtltr->record_failure; 16 | $rtltr->save; 17 | 18 | # Allow a one-time failure tolerance 19 | ok(!$rtltr->should_skip, 'We should not skip, there has been only one failure'); 20 | $rtltr->record_failure; 21 | $rtltr->save; 22 | 23 | ok($rtltr->should_skip, 'We should skip 1/1, there have been two failures'); 24 | $rtltr->save; 25 | 26 | ok(!$rtltr->should_skip, 'We should no longer skip, we skipped once already'); 27 | $rtltr->record_failure; 28 | $rtltr->save; 29 | 30 | ok($rtltr->should_skip, 'We should skip 1/2, again'); 31 | $rtltr->save; 32 | 33 | ok($rtltr->should_skip, 'We should skip 2/2, again'); 34 | $rtltr->save; 35 | 36 | ok(!$rtltr->should_skip, 'We should no longer skip'); 37 | $rtltr->record_failure; 38 | $rtltr->save; 39 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/06-auto-success.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 25; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 13 | 14 | ok(!$rtltr->should_skip, 'We should not skip, there has been no failure'); 15 | $rtltr->record_failure; 16 | $rtltr->save; 17 | 18 | # One-time failure tolerance 19 | ok(!$rtltr->should_skip, 'We should not skip, there has been only one failure'); 20 | $rtltr->record_failure; 21 | $rtltr->save; 22 | 23 | ok($rtltr->should_skip, 'We should skip 1/1, there have been two failures'); 24 | $rtltr->save; 25 | 26 | ok(!$rtltr->should_skip, 'We should not skip, there have been two failures'); 27 | $rtltr->record_failure; 28 | $rtltr->save; 29 | 30 | ok($rtltr->should_skip, 'We should skip 1/2, there have been two failures'); 31 | $rtltr->save; 32 | ok($rtltr->should_skip, 'We should skip 2/2, there have been two failures'); 33 | $rtltr->save; 34 | 35 | ok(!$rtltr->should_skip, 'We should not skip, there have been two failures'); 36 | $rtltr->save; 37 | 38 | is($rtltr->attempts, 0, "Last attempt was a success, rtltr should be reset"); 39 | ok(!$rtltr->should_skip, 'We should not skip, no failure was recorded in the last attempt'); 40 | 41 | # Simulate a bunch of successful attempts... 42 | for my $i (1..10) { 43 | $rtltr->save; 44 | ok(!$rtltr->should_skip, 'We should not skip, no failure was recorded in the last attempt'); 45 | } 46 | # With the last one actually failing: 47 | $rtltr->record_failure; 48 | $rtltr->save; 49 | 50 | # One-time failure tolerance 51 | ok(!$rtltr->should_skip, 'We should not skip, there has been only one failure'); 52 | $rtltr->record_failure; 53 | $rtltr->save; 54 | 55 | ok($rtltr->should_skip, 'We should skip 1/1, there have been two failures'); 56 | $rtltr->save; 57 | 58 | ok(!$rtltr->should_skip, 'We should not skip, there have been two failures'); 59 | $rtltr->record_failure; 60 | $rtltr->save; 61 | 62 | ok($rtltr->should_skip, 'We should skip 1/2, there have been three failures'); 63 | $rtltr->save; 64 | ok($rtltr->should_skip, 'We should skip 2/2, there have been three failures'); 65 | $rtltr->save; 66 | 67 | ok(!$rtltr->should_skip, 'We should not skip, there have been three failures'); 68 | $rtltr->record_failure; 69 | $rtltr->save; 70 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/07-multiple-failures.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 3; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 13 | $rtltr->should_skip; 14 | eval { 15 | ok($rtltr->record_failure, 'record_failure can be called once'); 16 | ok($rtltr->record_failure, 'record_failure can be called twice'); 17 | }; 18 | is($@, '', "record_failure can be called multiple times"); 19 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/08-just-a-lookup.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 5; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my $rtltr_store; 11 | 12 | { 13 | my $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 14 | 15 | is($rtltr->attempts, 0, 'No attempt has been recorded'); 16 | ok(!$rtltr->should_skip, 'Therefore, we should not skip'); 17 | is($rtltr->attempts, 1, 'One attempt has been recorded'); 18 | $rtltr->record_failure; 19 | # implicit save 20 | } 21 | 22 | { 23 | # Now just look up the number of attempts 24 | my $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 25 | is($rtltr->attempts, 1, 'One attempt has been recorded'); 26 | $rtltr->save; 27 | } 28 | 29 | { 30 | my $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 31 | is($rtltr->attempts, 1, 'Still only one attempt has been recorded'); 32 | } 33 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/09-auto-success-on-auto-save.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 6; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my $rtltr_store; 11 | 12 | { 13 | my $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 14 | 15 | is($rtltr->attempts, 0, 'No attempt has been recorded'); 16 | ok(!$rtltr->should_skip, 'Therefore, we should not skip'); 17 | is($rtltr->attempts, 1, 'One attempt has been recorded'); 18 | $rtltr->record_failure; 19 | # implicit save 20 | } 21 | 22 | { 23 | my $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 24 | is($rtltr->attempts, 1, 'One attempt has been recorded'); 25 | ok(!$rtltr->should_skip, 'Should not skip this time'); 26 | # auto success if we don't call record_failure 27 | # auto save when the object is destroyed 28 | } 29 | 30 | { 31 | my $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 32 | is($rtltr->attempts, 0, 'The object is reset upon success'); 33 | } 34 | -------------------------------------------------------------------------------- /t/Mirror/RateLimiter/20-errors.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 7; 7 | 8 | use Mirror::RateLimiter; 9 | 10 | my ($rtltr, $rtltr_store); 11 | 12 | ##### 13 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 14 | eval { 15 | $rtltr->record_failure; 16 | }; 17 | isnt($@, '', "A failure can't be recorded without first calling should_skip"); 18 | ##### 19 | 20 | 21 | ##### 22 | $rtltr_store = undef; 23 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 24 | 25 | ok(!$rtltr->should_skip, 'We should not skip, there has been no failure'); 26 | $rtltr->record_failure; 27 | $rtltr->save; 28 | 29 | # One-time failure tolerance 30 | ok(!$rtltr->should_skip, 'We should not skip, there has been only one failure'); 31 | $rtltr->record_failure; 32 | $rtltr->save; 33 | 34 | ok($rtltr->should_skip, 'We should skip 1/1, there have been two failures'); 35 | eval { 36 | $rtltr->record_failure; 37 | }; 38 | isnt($@, '', "A failure can't be recorded if it should have been skipped"); 39 | ##### 40 | 41 | 42 | ##### 43 | $rtltr_store = undef; 44 | $rtltr = Mirror::RateLimiter->load(\$rtltr_store); 45 | 46 | ok(!$rtltr->should_skip, 'We should not skip, there has been no failure'); 47 | $rtltr->record_failure; 48 | $rtltr->save; 49 | 50 | eval { 51 | $rtltr->record_failure; 52 | }; 53 | isnt($@, '', "A failure can't be recorded without first calling should_skip"); 54 | ##### 55 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Blackhole/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { 8 | use_ok('Mirror::Redirection::Blackhole'); 9 | } 10 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Blackhole/01-should_blackhole.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 6; 6 | 7 | use Mirror::Redirection::Blackhole; 8 | 9 | can_ok('Mirror::Redirection::Blackhole', 'should_blackhole'); 10 | 11 | eval { 12 | should_blackhole('', ''); 13 | 1; 14 | } or fail($@); 15 | pass('should_blackhole is exported'); 16 | 17 | # Should blackhole 18 | ok(should_blackhole('dists/wheezy/main/binary-i386/Packages.xz', 'archive'), 19 | "wheezy didn't include .xz versions of Packages files, so blackhole them"); 20 | 21 | ok(should_blackhole('dists/squeeze/InRelease', 'archive'), 22 | "squeeze didn't include InRelease files, so blackhole them"); 23 | 24 | ok(should_blackhole('dists/sid/main/binary-amd64/Packages', 'archive'), 25 | "uncompressed Packages files are not provided, so blackhole them"); 26 | 27 | # Should not blackhole 28 | ok(!should_blackhole('dists/wheezy/main/binary-i386/Packages.bz2', 'archive'), 29 | "wheezy did include .bz2 versions of Packages files, so do NOT blackhole them"); 30 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Blackhole/02-blackhole-for-jessie.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | use Mirror::Redirection::Blackhole; 8 | 9 | ok(should_blackhole('dists/jessie/main/binary-amd64/Packages.bz2', 'archive'), 10 | "bz2-compressed indexes are not provided for Jessie"); 11 | 12 | ok(!should_blackhole('dists/jessie/main/binary-amd64/Packages.gz', 'archive'), 13 | "gz-compressed indexes are still provided for Jessie"); 14 | 15 | ok(!should_blackhole('dists/jessie/main/binary-amd64/Packages.xz', 'archive'), 16 | "xz-compressed indexes are provided for Jessie"); 17 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Blackhole/02-blackhole-for-lts.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | use Mirror::Redirection::Blackhole; 8 | 9 | ok(should_blackhole('dists/squeeze-lts/main/binary-armel/Packages.gz', 'archive'), 10 | "Squeeze lts is limited to amd64 and i386, so blackhole other archs"); 11 | 12 | ok(!should_blackhole('dists/squeeze-lts/main/binary-amd64/Packages.gz', 'archive'), 13 | "Squeeze lts has amd64"); 14 | 15 | ok(!should_blackhole('dists/squeeze-lts/main/binary-i386/Packages.gz', 'archive'), 16 | "Squeeze lts has i386"); 17 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Blackhole/03-blackhole-for-sid.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 4; 6 | 7 | use Mirror::Redirection::Blackhole; 8 | 9 | ok(should_blackhole('dists/sid/main/binary-amd64/Packages.bz2', 'archive'), 10 | "bz2-compressed indexes are not provided for sid"); 11 | 12 | ok(should_blackhole('dists/sid/main/binary-amd64/Packages.lzma', 'archive'), 13 | "lzma-compressed indexes are not provided for sid"); 14 | 15 | ok(!should_blackhole('dists/sid/main/binary-amd64/Packages.gz', 'archive'), 16 | "gz-compressed indexes are still provided for sid"); 17 | 18 | ok(!should_blackhole('dists/sid/main/binary-amd64/Packages.xz', 'archive'), 19 | "xz-compressed indexes are provided for sid"); 20 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Permanent/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { 8 | use_ok('Mirror::Redirection::Permanent'); 9 | } 10 | -------------------------------------------------------------------------------- /t/Mirror/Redirection/Permanent/01-is_permanent.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 5; 6 | 7 | use Mirror::Redirection::Permanent; 8 | 9 | can_ok('Mirror::Redirection::Permanent', 'is_permanent'); 10 | 11 | eval { 12 | is_permanent('', ''); 13 | 1; 14 | } or fail($@); 15 | pass('is_permanent is exported'); 16 | 17 | # Permanent 18 | ok(is_permanent('pool/main/d/dpkg/dpkg_1.16.9_i386.deb', 'archive'), 19 | "a response for a deb file in pool is permanent"); 20 | 21 | ok(is_permanent('debian/dists/woody/main/binary-i386/Packages.gz', 'old'), 22 | "a response for any file in the 'old' archive is permanent"); 23 | 24 | # Non-permanent 25 | ok(!is_permanent('debian/dists/sid/main/binary-i386/Packages.gz', 'archive'), 26 | "a response for a dists file in the main archive is NON permanent"); 27 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/00-app.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | BEGIN { use_ok('Mirror::Redirector'); } 8 | 9 | my $app; 10 | 11 | eval { 12 | $app = Mirror::Redirector->new; 13 | }; 14 | is ($@, '', 'Failed to instantiate a new Mirror::Redirector'); 15 | 16 | can_ok($app, 'run'); 17 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/01-demo.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res = $cb->(GET "/?action=demo"); 17 | is($res->code, 200, "The request was 200/successful"); 18 | like($res->header('pragma'), qr/no-cache/i, "Pragma: no-cache"); 19 | }; 20 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/01-list.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 3; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res; 17 | 18 | $res = $cb->(GET "/?mirror=archive.list&arch=i386"); 19 | is($res->code, 200, "The request was 200/successful"); 20 | 21 | $res = $cb->(GET "/?mirror=archive.list"); 22 | is($res->code, 400, "The request was 400/bad request"); 23 | 24 | $res = $cb->(GET "/?mirror=archive.list&arch=foobar"); 25 | ok($res->is_error, "Request for the 'foobar' architecture is an error"); 26 | }; 27 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/02-forbidden-methods.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res; 17 | 18 | $res = $cb->(POST "/foo", content => 'foo'); 19 | is($res->code, 405, "POST is not an allowed method"); 20 | 21 | $res = $cb->(PUT "/foo"); 22 | is($res->code, 405, "PUT is not an allowed method"); 23 | }; 24 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/03-per-request-state.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 6; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res; 17 | 18 | $res = $cb->(GET "/?mirror=archive.list&arch=foobar"); 19 | ok($res->is_error, "Request for the 'foobar' architecture is an error"); 20 | 21 | $res = $cb->(GET "/?url=pool/main/d/dpkg/dpkg_1.16.9_i386.deb"); 22 | like($res->code, qr/^30[127]$/, "The request was a redirection"); 23 | }; 24 | 25 | # Reset the app 26 | $app = Mirror::Redirector->new; 27 | 28 | # FIXME: to reproduce the error the second request must not be 29 | # satisfied by the mirror(s) in the first request. 30 | test_psgi app => sub { $app->run(@_) }, client => sub { 31 | my $cb = shift; 32 | my $res; 33 | 34 | $res = $cb->(GET "/?mirror=archive&url=pool/main/d/dpkg/dpkg_1.16.9_i386.deb"); 35 | like($res->code, qr/^30[127]$/, "The request was a redirection"); 36 | like($res->header('location'), qr, "Pool path is correctly formed"); 37 | 38 | $res = $cb->(GET "/?mirror=backports&url=pool/main/d/dpkg/dpkg_1.16.9_i386.deb"); 39 | like($res->code, qr/^30[127]$/, "The request was a redirection"); 40 | like($res->header('location'), qr, "Pool path is correctly formed"); 41 | }; 42 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/04-modifying-globals.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 1; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res; 17 | my $pdbs; 18 | 19 | $res = $cb->(GET '/'); 20 | $pdbs = $Mirror::Redirector::peers_db_store; 21 | 22 | $res = $cb->(GET '/'); 23 | is($Mirror::Redirector::peers_db_store, $pdbs, "The global peers_db_store is not modified"); 24 | }; 25 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/05-url-cleanup.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my @requests = ( 13 | 'project/trace/ftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 14 | '/project/trace/ftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 15 | 'project/trace//ftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 16 | 'project%2Ftrace%2Fftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 17 | # TODO: 18 | # 'project/trace/../trace/ftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 19 | # Current behaviour: 20 | 'project/trace/../ftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 21 | 'project/trace/.//../ftp-master.debian.org' => 'project/trace/ftp-master.debian.org', 22 | 'project/trace/%2C' => 'project/trace/%2C', 23 | 'project/%0D%0AAnother-header:foo' => 'project/%0D%0AAnother-header%3Afoo', 24 | '../foo' => 'foo', 25 | 'xorg-server_1.10.4-1~bpo60+1.dsc' => 'xorg-server_1.10.4-1~bpo60+1.dsc', 26 | ); 27 | 28 | plan tests => scalar(@requests); 29 | 30 | my $app = Mirror::Redirector->new; 31 | 32 | test_psgi app => sub { $app->run(@_) }, client => sub { 33 | my $cb = shift; 34 | my $res; 35 | 36 | while (@requests) { 37 | my ($url_sent, $url_expected) = (shift @requests, shift @requests); 38 | 39 | $res = $cb->(GET "/?action=demo&url=$url_sent"); 40 | is($res->code, 200, 'The request was successful'); 41 | is($res->header('X-URL'), $url_expected, 'The url parameter is correctly escaped'); 42 | } 43 | }; 44 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/06-default-ip-for-tests.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res = $cb->(GET '/?action=demo'); 17 | is($res->code, 200, 'The request was successful'); 18 | is($res->header('X-IP'), '4.4.4.4', 'The default IP for tests is 4.4.4.4'); 19 | }; 20 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/06-set-local-ip.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 9; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | can_ok($app, qw'set_local_ip get_local_ip'); 15 | 16 | # Requests from 127.0.0.1 are translated as if they'd come from 8.8.8.8 17 | $app->set_local_ip('8.8.8.8'); 18 | is($app->get_local_ip('127.0.0.1'), '8.8.8.8', '127.0.0.1 is now translated to 8.8.8.8'); 19 | 20 | test_psgi app => sub { $app->run(@_) }, client => sub { 21 | my $cb = shift; 22 | my $res = $cb->(GET '/?action=demo'); 23 | is($res->code, 200, 'The request was successful'); 24 | is($res->header('X-IP'), '8.8.8.8', 'The local IP was translated to 8.8.8.8'); 25 | }; 26 | 27 | # Now as if they'd come from 8.8.4.4 28 | $app->set_local_ip('8.8.4.4'); 29 | is($app->get_local_ip('127.0.0.1'), '8.8.4.4', '127.0.0.1 is now translated to 8.8.4.4'); 30 | 31 | # Now using a user-defined function 32 | # This is mainly for use in tests and locally-run instances (where one 33 | # can modify the application), as M::Redirector only calls get_local_ip 34 | # on 127.0.0.1. It can, for example, be used to respect x-forwarded-for 35 | $app->set_local_ip(sub { 36 | my $req = shift; 37 | if ($req->header('x-forwarded-for')) { 38 | return $req->header('x-forwarded-for'); 39 | } 40 | return '8.8.8.8'; 41 | }); 42 | 43 | test_psgi app => sub { $app->run(@_) }, client => sub { 44 | my $cb = shift; 45 | my $res = $cb->(GET '/?action=demo'); 46 | is($res->code, 200, 'The request was successful'); 47 | is($res->header('X-IP'), '8.8.8.8', 'The local IP was translated to 8.8.8.8'); 48 | }; 49 | 50 | test_psgi app => sub { $app->run(@_) }, client => sub { 51 | my $cb = shift; 52 | my $res = $cb->(GET '/?action=demo', x_forwarded_for => '8.8.4.4'); 53 | is($res->code, 200, 'The request was successful'); 54 | is($res->header('X-IP'), '8.8.4.4', 'The local IP was translated to 8.8.4.4'); 55 | }; 56 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/07-multiple-link-headers.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res = $cb->(GET '/?action=demo'); 17 | is($res->code, 200, 'The request was successful'); 18 | like($res->header('Link'), qr/,\s* 3; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res = $cb->(GET "/?action=demo"); 17 | is($res->code, 200, "The request was 200/successful"); 18 | ok(defined($res->header('X-City')), "x-city"); 19 | ok(defined($res->header('X-Region')), "x-region"); 20 | }; 21 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/09-blackholed-requests.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res; 17 | 18 | $res = $cb->(GET "/?url=dists/squeeze/InRelease"); 19 | is($res->code, 404, "The request was blackholed"); 20 | 21 | $res = $cb->(GET "/?url=dists/sid/InRelease"); 22 | like($res->code, qr/^30\d$/, "The request was a redirection"); 23 | }; 24 | -------------------------------------------------------------------------------- /t/Mirror/Redirector/09-permanent-redirections.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 2; 7 | use Plack::Test; 8 | use HTTP::Request::Common; 9 | 10 | use Mirror::Redirector; 11 | 12 | my $app = Mirror::Redirector->new; 13 | 14 | test_psgi app => sub { $app->run(@_) }, client => sub { 15 | my $cb = shift; 16 | my $res; 17 | 18 | $res = $cb->(GET "/?url=pool/main/d/dpkg/dpkg_1.16.9_i386.deb"); 19 | is($res->code, 301, "The request was a permanent redirection"); 20 | 21 | $res = $cb->(GET "/?url=dists/sid/main/binary-i386/Packages.gz"); 22 | like($res->code, qr/^30[27]$/, "The request was a temporary redirection"); 23 | }; 24 | -------------------------------------------------------------------------------- /t/Mirror/Request/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { 8 | use_ok('Mirror::Request'); 9 | } 10 | -------------------------------------------------------------------------------- /t/Mirror/Request/01-architecture.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | use Mirror::Request; 8 | 9 | my @tests = ( 10 | 'pool/main/d/dpkg/dpkg_1.15.8.13_i386.deb' => 'i386', 11 | 'pool/main/d/dpkg/dpkg_1.15.8.13_amd64.deb' => 'amd64', 12 | 'dists/sid/main/binary-ia64/Packages.gz' => 'ia64', 13 | 'dists/sid/main/installer-powerpc/current/images/udeb.list' => 'powerpc', 14 | 'indices/files/components/arch-i386.list.gz' => 'i386', 15 | 'indices/files/arch-alpha.files' => 'alpha', 16 | 'dists/sid/main/binary-i386/Packages.diff/Index' => 'i386', 17 | 'dists/sid/main/Contents-armel.diff/Index' => 'armel', 18 | 'dists/sid/main/Contents-armel.gz' => 'armel', 19 | 'dists/sid/Contents-hurd-i386.gz' => 'hurd-i386', 20 | 'dists/sid/main/Contents-udeb-ia64.gz' => 'ia64', 21 | 'pool/main/d/dpkg/dpkg_1.15.8.13.dsc' => 'source', 22 | 'pool/main/d/dpkg/dpkg_1.15.8.13.tar.bz2' => 'source', 23 | 'pool/main/d/dpkg/dpkg_1.16.10.tar.xz' => 'source', 24 | 'pool/main/d/dpkg/libdpkg-perl_1.15.8.13_all.deb' => 'all', 25 | 'pool/main/l/le/le_1.14.3-1.diff.gz' => 'source', 26 | 'pool/main/l/le/le_1.14.9-2.debian.tar.gz' => 'source', 27 | 'pool/main/l/le/le_1.14.9.orig.tar.gz' => 'source', 28 | ); 29 | 30 | plan tests => (scalar(@tests)/2 + 1); 31 | 32 | can_ok('Mirror::Request', 'get_arch'); 33 | 34 | while (@tests) { 35 | my ($req, $arch) = (shift @tests, shift @tests); 36 | is(Mirror::Request::get_arch($req), $arch, "The architecture of the file is $arch"); 37 | } 38 | -------------------------------------------------------------------------------- /t/Mirror/Trace/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | BEGIN { use_ok('Mirror::Trace'); } 8 | -------------------------------------------------------------------------------- /t/Mirror/Trace/01-new.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace; 10 | eval { 11 | $trace = Mirror::Trace->new('http://0.0.0.0/'); 12 | } or fail($@); 13 | pass('Can create a new Mirror::Trace'); 14 | 15 | isa_ok($trace, 'Mirror::Trace'); 16 | -------------------------------------------------------------------------------- /t/Mirror/Trace/02-can-interface.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 1; 6 | 7 | use Mirror::Trace; 8 | 9 | can_ok('Mirror::Trace', qw(get_url from_string date uses_ftpsync good_ftpsync)); 10 | -------------------------------------------------------------------------------- /t/Mirror/Trace/03-parse-master-trace.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 2; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 19 | is($trace->date, 1330359184, 'Parsed date is correct'); 20 | -------------------------------------------------------------------------------- /t/Mirror/Trace/03-parse-trace.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 19; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 16 | is($trace->date, 1330359184, 'Parsed date is correct'); 17 | ok(!$trace->uses_ftpsync, 'Not an ftpync trace'); 18 | 19 | $trace_data = <from_string($trace_data), 'Parse trace data'); 26 | is($trace->date, 1330334034, 'Parsed date is correct'); 27 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 28 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 29 | 30 | $trace_data = <from_string($trace_data), 'Parse trace data'); 36 | is($trace->date, 1330356375, 'Parsed date is correct'); 37 | ok($trace->uses_ftpsync, 'ftpync-pushrsync is ftpsync'); 38 | ok($trace->good_ftpsync, 'ftpync-pushrsync is always good'); 39 | 40 | $trace_data = <from_string($trace_data), 'Parse trace data'); 47 | is($trace->date, 1333211725, 'Parsed date is correct'); 48 | ok($trace->uses_ftpsync, 'dms is like ftpsync'); 49 | ok($trace->good_ftpsync, 'dms 0.1 is good'); 50 | 51 | $trace_data = <from_string($trace_data), 'Parse trace data'); 58 | is($trace->date, 1333211725, 'Parsed date is correct'); 59 | ok($trace->uses_ftpsync, 'dms is like ftpsync'); 60 | ok(!$trace->good_ftpsync, 'dms 0.0.8-dev is not good'); 61 | -------------------------------------------------------------------------------- /t/Mirror/Trace/04-parse-empty-trace.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 4; 6 | use Test::Trap; 7 | 8 | use Mirror::Trace; 9 | 10 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 11 | 12 | my ($trace_data, $res); 13 | 14 | $trace_data = ''; 15 | 16 | $res = trap { $trace->from_string($trace_data) }; 17 | is($res, 0, 'Empty trace data'); 18 | is($trap->stderr, '', 'No errors parsing data'); 19 | 20 | 21 | $trace_data = ' 22 | '; 23 | 24 | $res = trap { $trace->from_string($trace_data) }; 25 | is($res, 0, 'Empty trace data w/new line'); 26 | is($trap->stderr, '', 'No errors parsing data'); 27 | -------------------------------------------------------------------------------- /t/Mirror/Trace/04-parse-ftpsync-20120521.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 20; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 20 | is($trace->date, 1330334034, 'Parsed date is correct'); 21 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 22 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 23 | 24 | $trace_data = <from_string($trace_data), 'Parse trace data'); 33 | is($trace->date, 1330334034, 'Parsed date is correct'); 34 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 35 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 36 | 37 | $trace_data = <from_string($trace_data), 'Parse trace data'); 46 | is($trace->date, 1330334034, 'Parsed date is correct'); 47 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 48 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 49 | 50 | $trace_data = <from_string($trace_data), 'Parse trace data'); 59 | is($trace->date, 1330334034, 'Parsed date is correct'); 60 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 61 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 62 | 63 | $trace_data = <from_string($trace_data), 'Parse trace data'); 72 | is($trace->date, 1330334034, 'Parsed date is correct'); 73 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 74 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 75 | -------------------------------------------------------------------------------- /t/Mirror/Trace/04-parse-ftpsync-20160306.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 10; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 20 | is($trace->date, 1461771541, 'Parsed date is correct'); 21 | 22 | $trace_data = <from_string($trace_data), 'Parse trace data'); 39 | is($trace->date, 1461772597, 'Parsed date is correct'); 40 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 41 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 42 | 43 | $trace_data = <from_string($trace_data), 'Parse trace data'); 62 | is($trace->date, 1461772250, 'Parsed date is correct'); 63 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 64 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 65 | -------------------------------------------------------------------------------- /t/Mirror/Trace/05-ftpsync-features.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 33; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 18 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 19 | ok(!$trace->features('inrelease'), '286 did not handle inrelease files'); 20 | ok(!$trace->features('i18n'), '286 did not handle i18n files'); 21 | 22 | $trace_data = <from_string($trace_data), 'Parse trace data'); 29 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 30 | ok($trace->features('inrelease'), '386 handles inrelease files'); 31 | ok(!$trace->features('i18n'), '386 did not handle i18n files'); 32 | 33 | $trace_data = <from_string($trace_data), 'Parse trace data'); 40 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 41 | ok($trace->features('inrelease'), '20120521 handles inrelease files'); 42 | ok($trace->features('i18n'), '20120521 handles i18n files'); 43 | 44 | $trace_data = <from_string($trace_data), 'Parse trace data'); 51 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 52 | ok($trace->features('inrelease'), '20130501 handles inrelease files'); 53 | ok($trace->features('i18n'), '20130501 handles i18n files'); 54 | ok($trace->features('auip'), '20130501 performs AUIP check'); 55 | 56 | $trace_data = <from_string($trace_data), 'Parse trace data'); 62 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 63 | ok($trace->features('inrelease'), 'pushrsync handles inrelease files'); 64 | ok($trace->features('i18n'), 'pushrsync handles i18n files'); 65 | 66 | $trace_data = <from_string($trace_data), 'Parse trace data'); 73 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 74 | ok(!$trace->features('inrelease'), 'dms 0.0.8 does not handle inrelease files'); 75 | ok(!$trace->features('i18n'), 'dms 0.0.8 does not handle i18n files'); 76 | 77 | $trace_data = <from_string($trace_data), 'Parse trace data'); 84 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 85 | ok($trace->features('inrelease'), 'dms handles inrelease files'); 86 | ok(!$trace->features('i18n'), 'dms 0.1 does not handle i18n files'); 87 | 88 | $trace_data = <from_string($trace_data), 'Parse trace data'); 95 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 96 | ok($trace->features('inrelease'), 'dms handles inrelease files'); 97 | ok($trace->features('i18n'), 'dms 0.2 does handle i18n files'); 98 | -------------------------------------------------------------------------------- /t/Mirror/Trace/06-architectures-field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 17; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 20 | ok($trace->arch('i386'), 'It includes i386'); 21 | ok($trace->arch('amd64'), 'It includes amd64'); 22 | 23 | $trace_data = <from_string($trace_data), 'Parse trace data'); 32 | ok($trace->arch('i386'), 'It includes i386'); 33 | ok($trace->arch('foo'), 'It includes "foo" (all of them)'); 34 | 35 | $trace_data = <from_string($trace_data), 'Parse trace data'); 44 | ok($trace->arch('i386'), 'It includes i386'); 45 | ok($trace->arch('amd64'), 'It includes amd64'); 46 | ok($trace->arch('s390'), 'It includes s390'); 47 | 48 | $trace_data = <from_string($trace_data), 'Parse trace data'); 57 | ok($trace->arch('i386'), 'It includes i386'); 58 | ok($trace->arch('amd64'), 'It includes amd64'); 59 | ok($trace->arch('source'), 'It includes source'); 60 | 61 | $trace_data = <from_string($trace_data), 'Parse trace data'); 70 | ok(!$trace->arch('amd64'), 'It does not include amd64'); 71 | ok(!$trace->arch('s390'), 'It does not include s390'); 72 | -------------------------------------------------------------------------------- /t/Mirror/Trace/06-bogus-architectures-field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | TODO: { 12 | 13 | local $TODO = "No real parsing is done yet"; 14 | 15 | my $trace_data = <from_string($trace_data), 'FULL mirror but lists an arch'); 24 | 25 | $trace_data = <from_string($trace_data), 'GUESSED archs lists with an especific arch'); 34 | 35 | $trace_data = <from_string($trace_data), 'Missing : after archs token'); 44 | } 45 | -------------------------------------------------------------------------------- /t/Mirror/Trace/06-empty-architectures-field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 10; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 18 | # can't check if a given arch is included without an archs field 19 | # so the right way to determine this is with: 20 | ok(!$trace->features('architectures'), "Trace doesn't have architectures field"); 21 | 22 | $trace_data = <from_string($trace_data), 'Parse trace data'); 31 | # This trace does list the architectures, so we can reliably tell 32 | # what is included 33 | ok($trace->features('architectures'), "Trace does have architectures field"); 34 | ok($trace->arch('i386')); 35 | 36 | # It can also happen that it is missing 37 | $trace_data = <from_string($trace_data), 'Missing architectures field'); 45 | ok(!$trace->features('architectures'), "Trace doesn't have architectures field"); 46 | 47 | # Or empty 48 | $trace_data = <from_string($trace_data), 'Parse trace data'); 57 | ok($trace->features('architectures'), "Trace does have architectures field"); 58 | ok(!$trace->arch('i386')); 59 | -------------------------------------------------------------------------------- /t/Mirror/Trace/07-revision-field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 10; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 21 | ok($trace->features('i18n'), 'Revised for i18n issue'); 22 | # Trust the revision field, not the version: 23 | ok(!$trace->features('inrelease'), 'Revised for InRelease issue'); 24 | 25 | $trace_data = <from_string($trace_data), 'Parse trace data'); 35 | ok($trace->features('i18n'), 'Custom script revised for i18n issue'); 36 | ok(!$trace->features('inrelease'), 'Custom script not revised for InRelease issue'); 37 | 38 | $trace_data = <from_string($trace_data), 'Parse trace data'); 48 | ok($trace->features('i18n'), 'Custom script revised for i18n issue'); 49 | ok($trace->features('inrelease'), 'Custom script revised for InRelease issue'); 50 | ok($trace->features('auip'), 'Custom script revised for AUIP check'); 51 | -------------------------------------------------------------------------------- /t/Mirror/Trace/90-broken-ftpsync-version.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 4; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 20 | is($trace->date, 1337613877, 'Parsed date is correct'); 21 | ok($trace->uses_ftpsync, 'ftpync trace'); 22 | ok(!$trace->good_ftpsync, 'broken ftpsync'); 23 | -------------------------------------------------------------------------------- /t/Mirror/Trace/91-GMT0-date-in-trace.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 4; 6 | 7 | use Mirror::Trace; 8 | 9 | my $trace = Mirror::Trace->new('http://0.0.0.0/'); 10 | 11 | my $trace_data = <from_string($trace_data), 'Parse trace data'); 20 | is($trace->date, 1351567538, 'Parsed date is correct'); 21 | ok($trace->uses_ftpsync, 'ftpync-generated trace'); 22 | ok($trace->good_ftpsync, 'Good version of ftpync is used'); 23 | -------------------------------------------------------------------------------- /translate-log.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | #################### 4 | # Copyright (C) 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | use Storable qw(retrieve); 27 | 28 | use Getopt::Long; 29 | 30 | sub get_mirror($); 31 | 32 | my $db_store = ''; 33 | my $translate_id = 1; 34 | my $translate_type = 0; 35 | my $generate_url = 0; 36 | 37 | GetOptions('db|mirrors-db=s' => \$db_store, 38 | 'i|translate-id!' => \$translate_id, 39 | 't|translate-type!' => \$translate_type, 40 | 'u|generate-url!' => \$generate_url) or exit 1; 41 | 42 | if ($generate_url) { 43 | $translate_id = 1; 44 | $translate_type = 1; 45 | } 46 | 47 | $| = 1; 48 | 49 | our $db; 50 | 51 | while (<>) { 52 | if ($. == 1) { 53 | if (m/^{db:([^}]+)}$/) { 54 | $db_store = $1; 55 | $_ = ''; 56 | } 57 | $db = retrieve($db_store || 'db'); 58 | } 59 | if (s,^\[(\w+)/(\w+)\],,) { 60 | my ($id, $type) = ($1, $2); 61 | my $replacement = $id; 62 | 63 | if ($translate_id) { 64 | die "unknown site $id" 65 | unless (get_mirror($id)); 66 | $replacement = get_mirror($id)->{'site'}; 67 | } 68 | if ($translate_type) { 69 | die "unknown type $type" 70 | unless (exists(get_mirror($id)->{"$type-http"})); 71 | $replacement .= get_mirror($id)->{"$type-http"}; 72 | } else { 73 | $replacement .= "/$type"; 74 | } 75 | if ($generate_url) { 76 | $replacement = 'http://'.$replacement; 77 | } 78 | print "[$replacement]"; 79 | print; 80 | } else { 81 | print; 82 | } 83 | } 84 | 85 | sub get_mirror($) { 86 | my $id = shift; 87 | 88 | if (exists($db->{'ipv4'}{'all'}{$id})) { 89 | return $db->{'ipv4'}{'all'}{$id}; 90 | } elsif (exists($db->{'ipv6'}{'all'}{$id})) { 91 | return $db->{'ipv6'}{'all'}{$id}; 92 | } else { 93 | return; 94 | } 95 | } 96 | -------------------------------------------------------------------------------- /update.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | #################### 4 | # Copyright (C) 2011, 2012 by Raphael Geissert 5 | # 6 | # This file is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This file is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this file If not, see . 18 | # 19 | # On Debian systems, the complete text of the GNU General 20 | # Public License 3 can be found in '/usr/share/common-licenses/GPL-3'. 21 | #################### 22 | 23 | set -eu 24 | 25 | geoip=true 26 | mirrors=true 27 | peers=true 28 | bgp=false 29 | 30 | while [ $# -gt 0 ]; do 31 | case "$1" in 32 | --geoip-only) 33 | mirrors=false 34 | peers=false 35 | ;; 36 | --mirrors-only) 37 | geoip=false 38 | peers=false 39 | ;; 40 | --peers-only) 41 | mirrors=false 42 | geoip=false 43 | ;; 44 | --bgp-only) 45 | mirrors=false 46 | geoip=false 47 | peers=false 48 | bgp=true 49 | ;; 50 | *) 51 | echo "usage: $(basename "$0") [--geoip-only|--mirrors-only|--peers-only|--bgp-only]" >&2 52 | exit 1 53 | ;; 54 | esac 55 | shift 56 | done 57 | 58 | if ! $geoip && ! $mirrors && ! $peers && ! $bgp; then 59 | echo "nice try" 60 | exit 1 61 | fi 62 | 63 | dir=/etc/ssl/ca-debian 64 | if [ -d $dir ]; then 65 | cadebian="--ca-directory=$dir" 66 | else 67 | cadebian= 68 | fi 69 | 70 | dir=/etc/ssl/ca-global 71 | if [ -d $dir ]; then 72 | caglobal="--ca-directory=$dir" 73 | else 74 | caglobal= 75 | fi 76 | 77 | if $geoip; then 78 | compression=gz 79 | if which unxz >/dev/null; then 80 | compression=xz 81 | fi 82 | 83 | mkdir -p geoip 84 | cd geoip 85 | for db in asnum/GeoIPASNum.dat.gz GeoLiteCity.dat.$compression asnum/GeoIPASNumv6.dat.gz GeoLiteCityv6-beta/GeoLiteCityv6.dat.gz; do 86 | wget $caglobal -U '' -N https://geolite.maxmind.com/download/geoip/database/$db 87 | db="$(basename "$db")" 88 | case "$db" in 89 | *.gz|*.xz) 90 | file_comp="${db##*.}" 91 | ;; 92 | *) 93 | echo "error: unknown compression of file $db" >&2 94 | exit 1 95 | ;; 96 | esac 97 | 98 | decomp_db="${db%.$file_comp}" 99 | if [ -f $decomp_db ]; then 100 | [ $db -nt $decomp_db ] || continue 101 | fi 102 | rm -f new.$db 103 | ln $db new.$db 104 | case "$file_comp" in 105 | gz) 106 | gunzip -f new.$db 107 | ;; 108 | xz) 109 | unxz -f new.$db 110 | ;; 111 | *) 112 | echo "error: unknown decompressor for .$file_comp" >&2 113 | exit 1 114 | ;; 115 | esac 116 | mv new.$decomp_db $decomp_db 117 | touch -r $db $decomp_db 118 | done 119 | cd - >/dev/null 120 | fi 121 | 122 | if $bgp; then 123 | mkdir -p bgp 124 | echo "Using bgp/ as cwd" 125 | cd bgp 126 | 127 | zdp=zebra-dump-parser/zebra-dump-parser.pl 128 | [ -x $zdp ] || { 129 | echo "error: couldn't find an executable zdp at $zdp" >&2 130 | exit 1 131 | } 132 | if [ -n "$(sed -rn '/^my\s+\$ignore_v6_routes\s*=\s*1/p' $zdp)" ]; then 133 | echo "warning: ipv6 routes are ignored by zdp, trying to fix it" >&2 134 | sed -ri '/^my\s+\$ignore_v6_routes\s*=\s*1/{s/=\s*1/= 0/}' $zdp 135 | fi 136 | 137 | wget -N http://data.ris.ripe.net/rrc00/latest-bview.gz 138 | zdpout="zdp-stdout-$(date -d "$(stat -c%y latest-bview.gz)" +%F)" 139 | 140 | echo "warning: expanding bgp dump to $zdpout, can take some 400MB" >&2 141 | zcat latest-bview.gz | $zdp > "$zdpout" 142 | 143 | cd - >/dev/null 144 | 145 | echo "Going to extract peers, resume with the following commands:" 146 | command=" 147 | ./extract-peers.pl --progress < 'bgp/$zdpout' 148 | sort -u peers.lst.d/routing-table.lst | LC_ALL=C sort -n | sponge peers.lst.d/routing-table.lst 149 | " 150 | echo "$command" 151 | eval "$command" 152 | fi 153 | 154 | if $peers; then 155 | if [ -z "$(find peers.lst.d/ -name '*.lst')" ]; then 156 | peers=false 157 | elif [ -f db ]; then 158 | ./build-peers-db.pl 159 | fi 160 | fi 161 | 162 | if $mirrors; then 163 | 164 | cd mirrors.lst.d 165 | wget $cadebian -O Mirrors.masterlist.new \ 166 | 'https://anonscm.debian.org/viewvc/webwml/webwml/english/mirror/Mirrors.masterlist?view=co' 167 | mv Mirrors.masterlist.new Mirrors.masterlist 168 | cd - >/dev/null 169 | 170 | ./build-main-db.pl --db-output db.wip 171 | if $peers; then 172 | ./build-peers-db.pl --mirrors-db db.wip 173 | fi 174 | ./check.pl --db-store db.wip --db-output db.in --check-everything --disable-sites '' | 175 | ./translate-log.pl 176 | fi 177 | --------------------------------------------------------------------------------