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