Tile cache: Restrict Moscow (gorynych) to EU and neighbour states
[dns.git] / bin / mkgeo
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 use IO::File;
7 use Math::Trig qw(deg2rad pip2 great_circle_distance);
8 use JSON::XS;
9 use LWP::UserAgent;
10 use XML::TreeBuilder;
11 use YAML;
12
13 my $source = shift @ARGV;
14 my $zone = shift @ARGV;
15 my $servers = YAML::LoadFile("src/${source}");
16
17 # Initialise server details
18 while (my($name,$server) = each %$servers)
19 {
20     $server->{name} = $name;
21     $server->{bandwidth_limit} = $server->{bandwidth} * 1024 * 1024;
22     $server->{bandwidth_used} = 0;
23
24     if ($ENV{PINGDOM_USERNAME} && $ENV{PINGDOM_PASSWORD})
25     {
26         $server->{status} = "down";
27     }
28     else
29     {
30         $server->{status} = "up";
31     }
32 }
33
34 # If pingdom support is enabled then check which servers are up
35 if ($ENV{PINGDOM_USERNAME} && $ENV{PINGDOM_PASSWORD})
36 {
37     my $ua = LWP::UserAgent->new;
38
39     $ua->default_header("App-Key", "2cohi62u5haxvqmypk3ljqqrze1jufrh");
40     $ua->credentials("api.pingdom.com:443", "Pingdom API", $ENV{PINGDOM_USERNAME}, $ENV{PINGDOM_PASSWORD});
41
42     foreach my $server (values %$servers)
43     {
44         if (my $checkid = $server->{pingdom})
45         {
46             my $response = $ua->get("https://api.pingdom.com/api/2.0/checks/${checkid}");
47
48             if ($response->is_success)
49             {
50                 my $check = decode_json($response->content);
51
52                 $server->{status} = $check->{check}->{status};
53             }
54         }
55     }
56 }
57
58 my %countries = ();
59 my @mappings = ();
60
61 # Create a parser for the country database
62 my $countries = XML::TreeBuilder->new;
63
64 # Parse the country database
65 $countries->parsefile("lib/countries.xml");
66
67 # Load the per-country bandwidth details
68 my $bandwidth = YAML::LoadFile("bandwidth/${source}.yml");
69
70 # Fill in country table and work out which servers each can use
71 foreach my $country ($countries->look_down("_tag" => "country"))
72 {
73     my $code = $country->look_down("_tag" => "countryCode")->as_text;
74     my $name = $country->look_down("_tag" => "countryName")->as_text;
75     my $population = $country->look_down("_tag" => "population")->as_text;
76     my $bandwidth = $bandwidth->{$code} || 0;
77     my $continent = $country->look_down("_tag" => "continent")->as_text;
78     my $west = $country->look_down("_tag" => "west")->as_text;
79     my $north = $country->look_down("_tag" => "north")->as_text;
80     my $east = $country->look_down("_tag" => "east")->as_text;
81     my $south = $country->look_down("_tag" => "south")->as_text;
82     my $lat = centre_lat( $south, $north );
83     my $lon = centre_lon( $west, $east );
84
85     $countries{$code} = {
86         code => $code, name => $name, continent => $continent,
87         bandwidth => $bandwidth, lat => $lat, lon => $lon
88     };
89
90     foreach my $server (values %$servers)
91     {
92         my $match = match_country($server, $code, $continent);
93
94         if ($server->{status} eq "up" && $match ne "denied")
95         {
96             my $priority = $match eq "preferred" ? 20 : 10;
97             my $distance = distance($lat, $lon, $server->{lat}, $server->{lon});
98
99             push @mappings, {
100                 country => $countries{$code}, server => $server,
101                 priority => $priority, distance => $distance
102             };
103         }
104     }
105 }
106
107 # Discard the parsed country database
108 $countries->delete;
109
110 # Allocate each country to a server
111 allocate_servers(\@mappings);
112
113 # If we failed to allocate every country then loop, increasing
114 # the bandwidth for each server by a little and retrying until
115 # we manage to allocate everything
116 while (grep { !exists($_->{server}) } values %countries)
117 {
118     # Clear any existing mappings of countries to servers
119     foreach my $country (values %countries)
120     {
121         delete $country->{server};
122     }
123
124     # Reset bandwidth usage for servers and increase limits by 10%
125     foreach my $server (values %$servers)
126     {
127         $server->{bandwidth_used} = 0;
128         $server->{bandwidth_limit} = $server->{bandwidth_limit} * 1.1;
129     }
130
131     # Try the allocate again
132     allocate_servers(\@mappings);
133 }
134
135 # Create JSON collection object
136 my @json;
137
138 # Open output files
139 my $zonefile = IO::File->new("> data/${zone}") || die "$!";
140 my $jsonfile = IO::File->new("> json/${zone}.json") || die "$!";
141
142 # Output details for each country
143 foreach my $country (values %countries)
144 {
145     my $server = $country->{server};
146     my $clon = $country->{lon};
147     my $clat = $country->{lat};
148     my $slon = $server->{lon};
149     my $slat = $server->{lat};
150
151     if ($clon > 0 && $slon < 0 && 360 + $slon - $clon < $clon - $slon)
152     {
153         $slon = $slon + 360;
154     }
155     elsif ($slon > 0 && $clon < 0 && 360 + $clon - $slon < $slon - $clon)
156     {
157         $clon = $clon + 360;
158     }
159
160     $zonefile->print("# $country->{name}\n");
161     $zonefile->print("C\L$country->{code}\E.${zone}:$server->{name}.${zone}:600\n");
162
163     push @json, {
164         type => "Feature",
165         geometry => {
166             type => "LineString",
167             coordinates => [ [ $clon, $clat ], [ $slon, $slat ] ]
168         },
169         properties => {
170             country => $country->{name},
171             server => $server->{name},
172             colour => $server->{colour}
173         }
174     };
175 }
176
177 # Output default records for IPs that can't be mapped to a country
178 foreach my $server (grep { $servers->{$_}->{default} } keys %$servers)
179 {
180     $zonefile->print("Cxx.${zone}:${server}.${zone}:600\n");
181 }
182
183 # Output the GeoJSON text
184 $jsonfile->print(encode_json(\@json));
185
186 # Close the output files
187 $jsonfile->close();
188 $zonefile->close();
189
190 exit 0;
191
192 #
193 # Find the centre value between two latitudes
194 #
195 sub centre_lat
196 {
197     my $south = shift;
198     my $north = shift;
199
200     return ( $south + $north ) / 2;
201 }
202
203 #
204 # Find the centre value between two longitudes
205 #
206 sub centre_lon
207 {
208     my $west = shift;
209     my $east = shift;
210     my $lon;
211
212     if ($west < $east)
213     {
214         $lon = ( $west + $east ) / 2;
215     }
216     else
217     {
218         $lon = ( $west + $east + 360 ) / 2;
219     }
220
221     $lon = $lon - 360 if $lon > 180;
222
223     return $lon
224 }
225
226 #
227 # Match a country against a server
228 #
229 sub match_country
230 {
231     my $server = shift;
232     my $country = shift;
233     my $continent = shift;
234     my $match;
235
236     if ($server->{preferred} &&
237         $server->{preferred}->{countries} &&
238         grep { $_ eq $country } @{$server->{preferred}->{countries}})
239     {
240         $match = "preferred";
241     }
242     elsif ($server->{preferred} &&
243            $server->{preferred}->{continents} &&
244            grep { $_ eq $continent } @{$server->{preferred}->{continents}})
245     {
246         $match = "preferred";
247     }
248     elsif ($server->{allowed} &&
249            $server->{allowed}->{countries} &&
250            grep { $_ eq $country } @{$server->{allowed}->{countries}})
251     {
252         $match = "allowed";
253     }
254     elsif ($server->{allowed} &&
255            $server->{allowed}->{continents} &&
256            grep { $_ eq $continent } @{$server->{allowed}->{continents}})
257     {
258         $match = "allowed";
259     }
260     elsif ($server->{denied} &&
261         $server->{denied}->{countries} &&
262         grep { $_ eq $country } @{$server->{preferred}->{countries}})
263     {
264         $match = "denied";
265     }
266     elsif ($server->{denied} &&
267            $server->{denied}->{continents} &&
268            grep { $_ eq $continent } @{$server->{preferred}->{continents}})
269     {
270         $match = "denied";
271     }
272     elsif ($server->{allowed})
273     {
274         $match = "denied";
275     }
276     else
277     {
278         $match = "allowed";
279     }
280
281     return $match;
282 }
283
284 #
285 # Compute the great circle distance between two points
286 #
287 sub distance
288 {
289     my $lat1 = deg2rad(shift);
290     my $lon1 = deg2rad(shift);
291     my $lat2 = deg2rad(shift);
292     my $lon2 = deg2rad(shift);
293
294     return great_circle_distance($lon1, pip2 - $lat1, $lon2, pip2 - $lat2);
295 }
296
297 #
298 # Allocate each country to a server
299 #
300 sub allocate_servers
301 {
302     my $mappings = shift;
303
304     # Loop over the mappings, trying to assign each country to the
305     # nearest server, but subject to the bandwidth limits
306     foreach my $mapping (sort {  $b->{priority} <=> $a->{priority} || $a->{distance} <=> $b->{distance} } @$mappings)
307     {
308         my $country = $mapping->{country};
309         my $server = $mapping->{server};
310
311         if (!exists($country->{server}) &&
312             $server->{bandwidth_used} + $country->{bandwidth} <= $server->{bandwidth_limit})
313         {
314             $country->{server} = $server;
315             $server->{bandwidth_used} = $server->{bandwidth_used} + $country->{bandwidth};
316         }
317     }
318
319     return;
320 }