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