7b70c2240020ebdd007ed2f08547225702b66fa6
[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 YAML;
11
12 my $originfile = shift @ARGV;
13 my $clusterfile = shift @ARGV;
14 my $zone = shift @ARGV;
15 my $targetoriginfile = shift @ARGV;
16 my $origins = YAML::LoadFile($originfile);
17 my $clusters = YAML::LoadFile($clusterfile);
18 my @servers;
19
20 # Initialise cluster details
21 while (my($name,$cluster) = each %$clusters)
22 {
23     if ($cluster->{servers})
24     {
25         $cluster->{bandwidth} = 0;
26
27         foreach my $server (@{$cluster->{servers}})
28         {
29             $server->{cluster} = $cluster;
30             $cluster->{bandwidth} = $cluster->{bandwidth} + $server->{bandwidth};
31
32             push @servers, $server;
33         }
34     }
35     else
36     {
37         my $server = {
38             cluster => $cluster,
39             pingdom => $cluster->{pingdom},
40             bandwidth => $cluster->{bandwidth},
41             ipv4 => $cluster->{ipv4},
42             ipv6 => $cluster->{ipv6}
43         };
44
45         $cluster->{servers} = [ $server ];
46
47         push @servers, $server;
48     }
49
50     $cluster->{name} = $name;
51     $cluster->{status} = "down";
52 }
53
54 # Initialise server details
55 foreach my $server (@servers)
56 {
57     $server->{status} = "up";
58 }
59
60 # If pingdom support is enabled then check which servers are up
61 if ($ENV{PINGDOM_USERNAME} && $ENV{PINGDOM_PASSWORD})
62 {
63     my $ua = LWP::UserAgent->new;
64     my $cache;
65
66     $ua->timeout(5);
67     $ua->default_header("App-Key", "2cohi62u5haxvqmypk3ljqqrze1jufrh");
68     $ua->credentials("api.pingdom.com:443", "Pingdom API", $ENV{PINGDOM_USERNAME}, $ENV{PINGDOM_PASSWORD});
69
70     if (-f "pingdom.yml")
71     {
72         $cache = YAML::LoadFile("pingdom.yml"); 
73     }
74     else
75     {
76         $cache = {};
77     }
78
79     foreach my $server (@servers)
80     {
81         if (my $checkid = $server->{pingdom})
82         {
83             my $response = $ua->get("https://api.pingdom.com/api/2.0/checks/${checkid}");
84
85             if ($response->is_success)
86             {
87                 my $check = decode_json($response->content);
88
89                 $server->{status} = $check->{check}->{status};
90                 $cache->{$server->{pingdom}} = $check->{check}->{status};
91             }
92             else
93             {
94                 $server->{status} = $cache->{$server->{pingdom}} || "down";
95             }
96         }
97     }
98
99     YAML::DumpFile("pingdom.yml", $cache);
100 }
101
102 # Mark a cluster as up if any servers are up
103 foreach my $server (@servers)
104 {
105     if ($server->{status} eq "up")
106     {
107         $server->{cluster}->{status} = "up";
108     }
109     else
110     {
111         $server->{cluster}->{bandwidth} = $server->{cluster}->{bandwidth} - $server->{bandwidth};
112     }
113 }
114
115 # Create target origins object
116 my $targetorigins = {};
117
118 # Initialise cluster details
119 while (my($name,$cluster) = each %$clusters)
120 {
121     $cluster->{bandwidth_limit} = $cluster->{bandwidth} * 1024 * 1024;
122     $cluster->{bandwidth_used} = 0;
123
124     $targetorigins->{$cluster->{name}} = {
125         code => $cluster->{name},
126         name => $cluster->{name},
127         lat => $cluster->{lat},
128         lon => $cluster->{lon},
129         bandwidth => 0
130     };
131 }
132
133 my @mappings = ();
134
135 # Scan origins and work out which clusters each can use
136 foreach my $origin (values %$origins)
137 {
138     foreach my $cluster (values %$clusters)
139     {
140         my $match = match_origin($cluster, $origin);
141
142         if ($cluster->{status} eq "up" && $match ne "denied")
143         {
144             my $priority = $match eq "preferred" ? 20 : 10;
145             my $distance = distance($origin->{lat}, $origin->{lon}, $cluster->{lat}, $cluster->{lon});
146
147             push @mappings, {
148                 origin => $origin, cluster => $cluster,
149                 priority => $priority, distance => $distance
150             };
151         }
152     }
153 }
154
155 # Allocate each country to a cluster
156 allocate_clusters(@mappings);
157
158 # If we failed to allocate every origin then loop, increasing
159 # the bandwidth for each cluster by a little and retrying until
160 # we manage to allocate everything
161 while (grep { !exists($_->{cluster}) } values %$origins)
162 {
163     # Clear any existing mappings of countries to clusters
164     foreach my $origin (values %$origins)
165     {
166         delete $origin->{cluster};
167     }
168
169     # Reset bandwidth usage for clusters and increase limits by 10%
170     foreach my $cluster (values %$clusters)
171     {
172         $cluster->{bandwidth_used} = 0;
173         $cluster->{bandwidth_limit} = $cluster->{bandwidth_limit} * 1.1;
174     }
175
176     # Try the allocate again
177     allocate_clusters(@mappings);
178 }
179
180 # Create JSON collection object
181 my @json;
182
183 # Open output files
184 my $zonefile = IO::File->new("> data/${zone}") || die "$!";
185 my $jsonfile = IO::File->new("> json/${zone}.json") || die "$!";
186
187 # Output details for each country
188 foreach my $origin (values %$origins)
189 {
190     my $cluster = $origin->{cluster};
191     my $clon = $origin->{lon};
192     my $clat = $origin->{lat};
193     my $slon = $cluster->{lon};
194     my $slat = $cluster->{lat};
195
196     if ($clon > 0 && $slon < 0 && 360 + $slon - $clon < $clon - $slon)
197     {
198         $slon = $slon + 360;
199     }
200     elsif ($slon > 0 && $clon < 0 && 360 + $clon - $slon < $slon - $clon)
201     {
202         $clon = $clon + 360;
203     }
204
205     $zonefile->print("# $origin->{name}\n");
206     $zonefile->print("C\L$origin->{code}\E.${zone}:$cluster->{name}.${zone}:600\n");
207
208     push @json, {
209         type => "Feature",
210         geometry => {
211             type => "LineString",
212             coordinates => [ [ $clon, $clat ], [ $slon, $slat ] ]
213         },
214         properties => {
215             origin => $origin->{name},
216             server => $cluster->{name},
217             colour => $cluster->{colour}
218         }
219     };
220
221     $targetorigins->{$cluster->{name}}->{bandwidth} += $origin->{bandwidth};
222 }
223
224 # Header for default records
225 $zonefile->print("# Unknown origins\n");
226
227 # Output default records for IPs that can't be mapped to a country
228 while (my($name,$cluster) = each %$clusters)
229 {
230     if (my $default = $cluster->{default})
231     {
232         output_server($zonefile, "${default}.${zone}", $cluster);
233     }
234     elsif (exists($cluster->{default}))
235     {
236         output_server($zonefile, "${zone}", $cluster);
237     }
238 }
239
240 # Header for underlying servers
241 $zonefile->print("# Servers\n");
242
243 # Output A records for each cluster
244 while (my($name,$cluster) = each %$clusters)
245 {
246     output_server($zonefile, "${name}.${zone}", $cluster);
247 }
248
249 # Output the GeoJSON text
250 $jsonfile->print(encode_json(\@json));
251
252 # Close the output files
253 $jsonfile->close();
254 $zonefile->close();
255
256 # Output the target details in origin format if required
257 YAML::DumpFile($targetoriginfile, $targetorigins) if $targetoriginfile;
258
259 exit 0;
260
261 #
262 # Match an origin against a cluster
263 #
264 sub match_origin
265 {
266     my $cluster = shift;
267     my $origin = shift;
268     my $match;
269
270     if ($cluster->{preferred} &&
271         $cluster->{preferred}->{countries} &&
272         grep { $_ eq $origin->{country} } @{$cluster->{preferred}->{countries}})
273     {
274         $match = "preferred";
275     }
276     elsif ($cluster->{allowed} &&
277            $cluster->{allowed}->{countries} &&
278            grep { $_ eq $origin->{country} } @{$cluster->{allowed}->{countries}})
279     {
280         $match = "allowed";
281     }
282     elsif ($cluster->{denied} &&
283            $cluster->{denied}->{countries} &&
284            grep { $_ eq $origin->{country} } @{$cluster->{denied}->{countries}})
285     {
286         $match = "denied";
287     }
288     elsif ($cluster->{preferred} &&
289            $cluster->{preferred}->{continents} &&
290            grep { $_ eq $origin->{continent} } @{$cluster->{preferred}->{continents}})
291     {
292         $match = "preferred";
293     }
294     elsif ($cluster->{allowed} &&
295            $cluster->{allowed}->{continents} &&
296            grep { $_ eq $origin->{continent} } @{$cluster->{allowed}->{continents}})
297     {
298         $match = "allowed";
299     }
300     elsif ($cluster->{denied} &&
301            $cluster->{denied}->{continents} &&
302            grep { $_ eq $origin->{continent} } @{$cluster->{denied}->{continents}})
303     {
304         $match = "denied";
305     }
306     elsif ($cluster->{allowed})
307     {
308         $match = "denied";
309     }
310     else
311     {
312         $match = "allowed";
313     }
314
315     return $match;
316 }
317
318 #
319 # Compute the great circle distance between two points
320 #
321 sub distance
322 {
323     my $lat1 = deg2rad(shift);
324     my $lon1 = deg2rad(shift);
325     my $lat2 = deg2rad(shift);
326     my $lon2 = deg2rad(shift);
327
328     return great_circle_distance($lon1, pip2 - $lat1, $lon2, pip2 - $lat2);
329 }
330
331 #
332 # Allocate each origin to a cluster
333 #
334 sub allocate_clusters
335 {
336     my @mappings = sort { compare_mappings($a, $b) } @_;
337
338     # Loop over the mappings, trying to assign each origin to the
339     # nearest cluster, but subject to the bandwidth limits
340     while (my $mapping = shift @mappings)
341     {
342         my @group;
343
344         push @group, $mapping;
345
346         while (@mappings && compare_mappings($mapping, $mappings[0]) == 0)
347         {
348             push @group, shift @mappings;
349         }
350
351         for my $mapping (sort compare_bandwidth @group)
352         {
353             my $origin = $mapping->{origin};
354             my $cluster = $mapping->{cluster};
355
356             if (!exists($origin->{cluster}) &&
357                 $cluster->{bandwidth_used} + $origin->{bandwidth} <= $cluster->{bandwidth_limit})
358             {
359                 $origin->{cluster} = $cluster;
360                 $cluster->{bandwidth_used} = $cluster->{bandwidth_used} + $origin->{bandwidth};
361             }
362         }
363     }
364
365     return;
366 }
367
368 #
369 # Compare two mappings to decide which to use
370 #
371 sub compare_mappings
372 {
373     my $a = shift;
374     my $b = shift;
375
376     return $b->{priority} <=> $a->{priority} ||
377            $a->{distance} <=> $b->{distance};
378 }
379
380 #
381 # Compare two mappings to decide which to try first
382 #
383 sub compare_bandwidth
384 {
385     my $a_used = ( $a->{cluster}->{bandwidth_used} * 100.0 ) / ( $a->{cluster}->{bandwidth_limit} * 1.0 );
386     my $b_used = ( $b->{cluster}->{bandwidth_used} * 100.0 ) / ( $b->{cluster}->{bandwidth_limit} * 1.0 );
387
388     return $a_used <=> $b_used;
389 }
390
391 #
392 # Output DNS records for a server
393 #
394 sub output_server
395 {
396     my $zonefile = shift;
397     my $name = shift;
398     my $cluster = shift;
399
400     foreach my $server (@{$cluster->{servers}})
401     {
402         if ($server->{status} eq "up")
403         {
404             $zonefile->print("+${name}:$server->{ipv4}:3600\n");
405
406             if ($server->{ipv6})
407             {
408 #                $zonefile->print("3${name}:$server->{ipv6}:3600\n");
409             }
410         }
411     }
412
413     return;
414 }