Rework mkgeo to use bandwidth constraints
[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::Writer;
11 use XML::TreeBuilder;
12 use YAML;
13
14 my $source = shift @ARGV;
15 my $zone = shift @ARGV;
16 my $servers = YAML::LoadFile("src/${source}");
17
18 # Initialise server details
19 while (my($name,$server) = each %$servers)
20 {
21     $server->{name} = $name;
22     $server->{bandwidth} = $server->{bandwidth} * 1024 * 1024;
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 # Loop over the mappings, trying to assign each country to the
111 # nearest server, but subject to the bandwidth limits;
112 foreach my $mapping (sort {  $b->{priority} <=> $a->{priority} || $a->{distance} <=> $b->{distance} } @mappings)
113 {
114     my $country = $mapping->{country};
115     my $server = $mapping->{server};
116
117     if ($country->{bandwidth} <= $server->{bandwidth} && !exists($country->{server}))
118     {
119         $country->{server} = $server;
120         $server->{bandwidth} = $server->{bandwidth} - $country->{bandwidth};
121     }
122 }
123
124 # Loop over the mappings again, assigning anything that is left
125 # as best we can, and allowing bandwidth limits to be exeeded
126 foreach my $mapping (sort {  $b->{priority} <=> $a->{priority} || $a->{distance} <=> $b->{distance} } @mappings)
127 {
128     my $country = $mapping->{country};
129     my $server = $mapping->{server};
130
131     $country->{server} = $server unless exists($country->{server});
132 }
133
134 # Open output files
135 my $zonefile = IO::File->new("> data/${zone}") || die "$!";
136 my $kmlfile = IO::File->new("> kml/${zone}.kml") || die "$!";
137 my $kmlwriter = XML::Writer->new(OUTPUT => $kmlfile, ENCODING => 'utf-8');
138
139 # Output the KML header
140 $kmlwriter->xmlDecl();
141 $kmlwriter->startTag("kml", "xmlns" => "http://www.opengis.net/kml/2.2");
142 $kmlwriter->startTag("Document");
143
144 # Output details for each country
145 foreach my $country (values %countries)
146 {
147     my $server = $country->{server};
148     my $clon = $country->{lon};
149     my $clat = $country->{lat};
150     my $slon = $server->{lon};
151     my $slat = $server->{lat};
152
153     if ($clon > 0 && $slon < 0 && 360 + $slon - $clon < $clon - $slon)
154     {
155         $clon = $clon - 360;
156     }
157     elsif ($slon > 0 && $clon < 0 && 360 + $clon - $slon < $slon - $clon)
158     {
159         $slon = $slon - 360;
160     }
161
162     $zonefile->print("C\L$country->{code}\E.${zone}:$server->{name}.${zone}:600\n");
163
164     $kmlwriter->startTag("Placemark");
165     $kmlwriter->dataElement("name", $country->{name});
166     $kmlwriter->startTag("LineString");
167     $kmlwriter->dataElement("coordinates", "$clon,$clat $slon,$slat");
168     $kmlwriter->endTag("LineString");
169     $kmlwriter->endTag("Placemark");
170 }
171
172 # Output default records for IPs that can't be mapped to a country
173 foreach my $server (grep { $servers->{$_}->{default} } keys %$servers)
174 {
175     $zonefile->print("Cxx.${zone}:${server}.${zone}:600\n");
176 }
177
178 # End the KML file
179 $kmlwriter->endTag("Document");
180 $kmlwriter->endTag("kml");
181 $kmlwriter->end();
182
183 # Close the output files
184 $kmlfile->close();
185 $zonefile->close();
186
187 exit 0;
188
189 #
190 # Find the centre value between two latitudes
191 #
192 sub centre_lat
193 {
194     my $south = shift;
195     my $north = shift;
196
197     return ( $south + $north ) / 2;
198 }
199
200 #
201 # Find the centre value between two longitudes
202 #
203 sub centre_lon
204 {
205     my $west = shift;
206     my $east = shift;
207     my $lon;
208
209     if ($west < $east)
210     {
211         $lon = ( $west + $east ) / 2;
212     }
213     else
214     {
215         $lon = ( $west + $east + 360 ) / 2;
216     }
217
218     $lon = $lon - 360 if $lon > 180;
219
220     return $lon
221 }
222
223 #
224 # Match a country against a server
225 #
226 sub match_country
227 {
228     my $server = shift;
229     my $country = shift;
230     my $continent = shift;
231     my $match;
232
233     if ($server->{preferred} &&
234         $server->{preferred}->{countries} &&
235         grep { $_ eq $country } @{$server->{preferred}->{countries}})
236     {
237         $match = "preferred";
238     }
239     elsif ($server->{preferred} &&
240            $server->{preferred}->{continents} &&
241            grep { $_ eq $continent } @{$server->{preferred}->{continents}})
242     {
243         $match = "preferred";
244     }
245     elsif ($server->{allowed} &&
246            $server->{allowed}->{countries} &&
247            grep { $_ eq $country } @{$server->{allowed}->{countries}})
248     {
249         $match = "allowed";
250     }
251     elsif ($server->{allowed} &&
252            $server->{allowed}->{continents} &&
253            grep { $_ eq $continent } @{$server->{allowed}->{continents}})
254     {
255         $match = "allowed";
256     }
257     elsif ($server->{denied} &&
258         $server->{denied}->{countries} &&
259         grep { $_ eq $country } @{$server->{preferred}->{countries}})
260     {
261         $match = "denied";
262     }
263     elsif ($server->{denied} &&
264            $server->{denied}->{continents} &&
265            grep { $_ eq $continent } @{$server->{preferred}->{continents}})
266     {
267         $match = "denied";
268     }
269     elsif ($server->{allowed})
270     {
271         $match = "denied";
272     }
273     else
274     {
275         $match = "allowed";
276     }
277
278     return $match;
279 }
280
281 #
282 # Compute the great circle distance between two points
283 #
284 sub distance
285 {
286     my $lat1 = deg2rad(shift);
287     my $lon1 = deg2rad(shift);
288     my $lat2 = deg2rad(shift);
289     my $lon2 = deg2rad(shift);
290
291     return great_circle_distance($lon1, pip2 - $lat1, $lon2, pip2 - $lat2);
292 }