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