pool

# -*- cperl -*-
eval 'exec $CBROOT/bin/perl $0 ${1+"$@"}'
  unless $running_under_some_shell;
use strict;
use Combust::DB;
use Combust::Config;
use List::Util qw(shuffle);
use Net::hostent;
use Net::NTP;
use Socket;
use Time::HiRes;
use Data::Dumper;
use Sys::Hostname qw(hostname);
use Geo::IP;
use Net::IP;
use LWP::Simple;
use Email::Simple;
use Email::Date;
use Email::Send 'SMTP';
use File::Path qw(mkpath);
use JSON::XS ();
use Math::Random::Secure qw(irand);

my $geo_ip = eval "Geo::IP->new(GEOIP_STANDARD)";

use NP::Model;

use constant LOGFILE => "$ENV{CBROOTLOCAL}/log";

my $pool_domain = Combust::Config->new->site->{ntppool}->{pool_domain}
  or die "pool_domain configuration not setup";

$Net::NTP::TIMEOUT = 2;

my $db;

# exit handler
sub closedbconnection {
    $db->rollback();
    $db->disconnect();
}

# tools
sub ntpdate {
    my ($host, $error) = @_;

    my %ntp = eval { get_ntp_response($host); };
    warn Data::Dumper->Dump([\%ntp]);

    my @error;

    $ntp{Stratum} ||= '';
    push @error, "Bad stratum: $ntp{Stratum}"
      unless $ntp{Stratum}
          and $ntp{Stratum} < 6;

    if (@error) {
        print @error, "\n";
        my @query = `ntpdate -q $host 2>&1`
          or die "Error in command execution: ntpdate\n";
        print @query;

        return undef;
    }

    return 1;
}

sub logsay {
    my $msg = join " ", @_;
    open LOG, ">>" . LOGFILE
      or die "Opening log (" . LOGFILE . "): $!\n";
    my (undef, undef, undef, $d, $m, $y, undef) = localtime time;
    printf LOG "%04d%02d%02d clockmaster %s\n", $y + 1900, $m + 1, $d, $msg;
    close LOG;
}

sub server_information {
    my $server = shift;
    my @zones  = $server->zones_display;
    my @r;
    push @r, sprintf "IP: %s, ID: %i, username: %s email: %s\n",
      $server->ip,
      $server->id,
      $server->admin->username ? $server->admin->username : "-",
      $server->admin->email;
    push @r, sprintf "score: %.1f, in pool: %i, in server list: %i\n",
      $server->score, $server->in_pool, $server->in_server_list;
    push @r, "Hostname: " . $server->hostname . "\n";
    my $country = $geo_ip->country_code_by_addr($server->ip);
    $country = lc $country if $country;
    push @r, "Country: $country  -  " if $country;
    push @r, "Netspeed: " . $server->netspeed . "\n";
    push @r, "Zones: ", join(", ", map { $_->name } @zones), "\n";
    push @r, sprintf "in_pool: %i, in_server_list: %i\n", $server->in_pool, $server->in_server_list;
    push @r, "Deletion on: ", $server->deletion_on->ymd, "\n"
      if $server->deletion_on;
    @r;
}

if ($#ARGV < 0) {
    die "pool add|report|addmonitor|zone [<args>]\n";
}

# connect to the db
$db = Combust::DB::db_open('ntppool', {AutoCommit => 0})
  or die "Couldn't connect to database\n";

#$SIG{__DIE__} = \&closedbconnection;

sub find_user_by_email {
    my $email = shift;
    my $user = NP::Model->user->fetch(email => $email);
    $user = NP::Model->user->fetch(username => $email) unless $user;
    $user = NP::Model->user->fetch(id       => $email) unless $user;
    $user = NP::Model->user->fetch_or_create(email => $email) unless $user;
    $user->save;
    return $user;
}

my $cmd = shift @ARGV;
if ($cmd eq "add") {
    if ($#ARGV < 1) {
        die "pool add <email> <host or IP> [<zone ...>]\n";
    }

    # look if the email address is already registered
    my $email = shift @ARGV;
    my $user = find_user_by_email($email);

    # do we have a hostname or an IP?
    my $hostname = shift @ARGV;
    my $ip;
    if (Net::IP::ip_is_ipv4($hostname)) {
        $ip       = $hostname;
        $hostname = undef;
    }
    else {
        my $addrs = gethostbyname($hostname)
          or die "$hostname does not resolve.\n";
        if ($#{$addrs->addr_list} > 0) {
            print "warning: $hostname has multiple IP addresses.\n";
        }
        $ip = inet_ntoa(${$addrs->addr_list}[0]);
    }

    # test the timeserver
    ntpdate $ip, "Bad server " . ($hostname ? $hostname : "") . "[$ip]:"
      or exit;

    my $server = NP::Model->server->fetch(ip => $ip);
    if ($server) {
        die "server $ip already in database for ", $server->user->email, "\n";
    }

    $server = NP::Model->server->create(
        ip       => $ip,
        hostname => $hostname,
        user_id  => $user->id,
        in_pool  => 1,
    );

    for my $country (@ARGV) {
        $server->join_zone($country);
    }

    $server->save;

    unless (defined $hostname) { $hostname = $ip; }
    my $z = join " ", @ARGV;
    logsay($server->id . " add $email $hostname $z");

}
elsif ($cmd eq "addmonitor") {
    if ($#ARGV < 2) {
        die "pool addmonitor <email> <host or IP> <ip_version>\n";
    }

    my ($email, $hostname, $ip_version) = @ARGV;

    die "ip_version must be v4 or v6" unless $ip_version =~ m/^v[46]$/;

    my $db = NP::Model->db;
    my $txn  = $db->begin_scoped_work or die $db->error;

    # look if the email address is already registered
    my $user = find_user_by_email($email);

    # do we have a hostname or an IP?
    my $ip = Net::IP->new($hostname);

    if ($ip) {
        $ip       = $ip->short;
        $hostname = undef;
    }
    else {
        my $addrs = gethostbyname($hostname)
          or die "$hostname does not resolve.\n";
        if ($#{$addrs->addr_list} > 0) {
            print "warning: $hostname has multiple IP addresses.\n";
        }
        $ip = inet_ntoa(${$addrs->addr_list}[0]);
    }

    my $monitor = NP::Model->monitor->create(
        ip       => $ip,
        user_id  => $user->id,
        ip_version => $ip_version,
    );

    require Math::BaseCalc;
    my $base36 = Math::BaseCalc->new(digits => ['a'..'k', 'm'..'z', 2..9]);

    my @numbers = map { $base36->to_base(irand) } (undef) x 3;
    my $api_key = join "", @numbers;

    $monitor->api_key( $api_key );

    $monitor->save;

    my $id = $monitor->id;

    $db->dbh->do( q[ insert into server_scores (monitor_id, server_id, score_raw)
                      select ?, id, score_raw from servers
                      where ip_version = ? and deletion_on is null
                     ], {}, $monitor->id, $monitor->ip_version );

    for my $f (qw(ip ip_version api_key)) {
        printf "%-10s: %s\n", $f, $monitor->$f;
    }

    $db->commit or die $db->error;

}
elsif ($cmd eq "edit") {
    my $arg = shift @ARGV or die "pool zones <host or IP>\n";
    my $server = NP::Model->server->find_server($arg);
    die "Could not find server $arg\n" unless $server;
    print server_information($server);
    my $changes = 0;
    while (my $k = shift @ARGV) {
        $changes++;
        print "\n";
        my $v = shift @ARGV;
        last unless defined $v;
        print "Set $k -> $v";
        if ($server->can($k)) {
            $server->$k($v);
        }
        else {
            die "Don\'t know how to set $k\n";
        }
    }
    if ($changes and $server->save(changes_only => 1) > 0) {
        print "\n\nUpdated =============\n";
        print server_information($server);
    }
}
elsif ($cmd eq "zones") {
    my $arg = shift @ARGV or die "pool zones <host or IP>\n";
    my $server = NP::Model->server->find_server($arg);
    die "Could not find server $arg\n" unless $server;
    print "\n";
    print server_information($server);
    my @zones = $server->zones;
    for my $zone_name (@ARGV) {
        my @zones = $server->zones;
        if ($zone_name =~ s/^-//) {
            my ($zone) = grep { $_->name eq $zone_name } @zones;
            print "Could not find location '$zone_name' to delete\n" and next
              unless $zone;
            $server->leave_zone($zone_name);
        }
        else {
            $zone_name =~ s/^\+//;
            next if grep { $zone_name eq $_->name } @zones;
            my $zone = NP::Model->zone->fetch(name => $zone_name);
            print "Could not find '$zone_name'\n" and next unless $zone;
            $server->join_zone($zone);
        }
    }
    $server->save;

    @zones = $server->zones_display;
    print "Zones: ", join(", ", map { $_->name } @zones), "\n";
}
elsif ($cmd eq "rm") {
    my $arg = shift @ARGV
      or die "pool rm <host or IP>\n";
    my $server = NP::Model->server->find_server($arg);
    die "Could not find server $arg\n" unless $server;
    my $server_desc = (join " / ", grep { defined $_ } $server->ip, $server->hostname);
    logsay($server->id, "rm", $server_desc);
    printf "%i, %s - %s\n", $server->id, $server_desc, $server->user->email;
    my $date = DateTime->today;
    $server->deletion_on($date);
    $server->add_logs(
        {   user_id => undef,
            type    => 'delete',
            message => "Deletion scheduled for " . $date->ymd . " by pool admin"
        }
    );
    $server->update;
}
elsif ($cmd eq "ip") {
    my ($from, $to) = @ARGV;
    $to or die "pool $cmd <host or IP> <IP>\n";
    my $server = NP::Model->server->find_server($from);
    die "Could not find server $from\n" unless $server;
    print server_information($server);
    my $server_desc = (join " / ", grep { defined $_ } $server->ip, $server->hostname);
    logsay($server->id, "ip", "$server_desc => $to");
    printf "%i, %s (%s) => %s\n", $server->id, $server_desc, $server->admin->email, $to;
    $server->add_logs(
        {   user_id => undef,
            type    => 'ip_change',
            message => "IP change from " . $server->ip . " to $to",
        }
    );
    $server->ip($to);
    $server->score_raw(0);
    $server->save;
}
elsif ($cmd eq "report") {

    my $rcpt = shift;

    my $config = Combust::Config->new;
    my $url    = $config->base_url("ntppool") . "/bulletin";
    my $msg    = get($url);

    die "no msg?!" unless $msg;

    my $head = "";

    $rcpt and $head = <<EOT;
From: $pool_domain monitoring script <clockmaster\@fortytwo.ch>
To: <$rcpt>
EOT

    #  timekeepers-bulletin@fortytwo.ch

    if ($rcpt) {
        my $email = Email::Simple->new($head . $msg);
        $email->header_set('Message-ID' => join("-", int(rand(1000)), $$, time) . '@' . hostname);
        $email->header_set('Date' => Email::Date::format_date);

        my $return = send SMTP => $email, 'localhost';
    }
    else {
        print $msg;
    }

}
elsif ($cmd eq "zone") {

    mkpath "$ENV{CBROOTLOCAL}/dns/", 0, 0711;

    my $file = "$ENV{CBROOTLOCAL}/dns/$pool_domain";
    open(my $fh, ">$file.tmp") or die "Could not open $file.tmp: $!";

    open HEAD, "<header"
      or die "Opening DNS zone file header (header): $!\n";
    print $fh "# ATTENTION\n# This is a generated file\n#\n";
    my $time = time;
    while (<HEAD>) {
        s/\@VERSION\@/$time/;
        print $fh $_;
    }
    close HEAD;

    my $ttl     = 390;
    my $pgeodns = {
        serial => $time,
        ttl    => $ttl,
    };

    my $www_record = {
        cname => 'ntppool-varnish.develooper.com',
        ttl   => 7200,
    };

    $pgeodns->{data}->{www} = $www_record;
    $pgeodns->{data}->{web} = $www_record;

    # todo: check logs that this isn't used...
    for (0 .. 3) {
        $pgeodns->{data}->{"$_.vendors"} = {
            cname => "$_.$pool_domain",
            ttl   => 43200,
        };
    }

    my $vendordir = "vendordns";
    opendir my $dir, $vendordir or die "could not open '$vendordir' dir: $!";
    my @vendor_files =
      grep { $_ !~ /\~$/ and -f $_ } map {"$vendordir/$_"} readdir($dir);
    closedir $dir;

    # We used to read the data from the vendor files as tinydns data; now we
    # just include them with the other vendor zone names...

    my $vendor_zones = NP::Model->vendor_zone->get_vendor_zones(
        query => [status => 'Approved'],
        order => 'approved_on',
    );

    my @vendor_zone_names = map { $_->zone_name } @$vendor_zones;
    push @vendor_zone_names, map { s!.*/!!; $_ } @vendor_files;

    for my $name (@vendor_zone_names) {
        for my $i (0 .. 3) {
            $pgeodns->{data}->{"$i.$name"}->{alias} = "$i";
            print $fh "C$i.$name.${pool_domain}:$i.${pool_domain}:$ttl\n";
        }
    }

    my $zones = NP::Model->zone->get_zones_iterator(query => [dns => 1]);

    while (my $zone = $zones->next) {
        my $name = $zone->name;
        $name = '' if $name eq '@';
        $name = "$name." if $name;

        if (my $entries = $zone->active_servers('v4')) {

            my $min_non_duplicate_size = 2;
            my $response_records       = 3;
            my @zones                  = ("", "0.", "1.", "2.", "3.");
            my $zone_count             = scalar @zones;

            $min_non_duplicate_size = int(@$entries / $zone_count)
              if (@$entries / $zone_count > $min_non_duplicate_size);

            print $fh "# " . scalar @$entries . " active servers in ", $zone->name, "\n";

            if ($#$entries < ($min_non_duplicate_size * $zone_count - 1)) {
                print $fh "# possible duplicates in the zones below (", $zone->name, ")\n";
                foreach my $z (@zones) {
                    (my $pgeodns_group = "$z${name}") =~ s/\.$//;
                    $pgeodns->{data}->{$pgeodns_group}->{a} = [];
                    @$entries = shuffle(@$entries);
                    my $i;
                    foreach my $e (@$entries) {
                        $i++;
                        print $fh "+$z${name}${pool_domain}:$$e[0]:$ttl\n"
                          if $i < 12;
                        push @{$pgeodns->{data}->{$pgeodns_group}->{a}}, $e;
                    }
                }
            }
            else {
                print $fh "# 'big' zone without duplicates below (", $zone->name, ")\n";
                @$entries = shuffle(@$entries);
                foreach my $z (@zones) {
                    (my $pgeodns_group = "$z${name}") =~ s/\.$//;
                    $pgeodns->{data}->{$pgeodns_group}->{a} = [];
                    for (my $i = 0; $i < $min_non_duplicate_size; $i++) {
                        my $e = shift @$entries;
                        print $fh "+$z${name}${pool_domain}:", $e->[0], ":$ttl\n"
                          if $i < 14;
                        push @{$pgeodns->{data}->{$pgeodns_group}->{a}}, $e;
                    }
                }
            }
        }

        if (my $entries = $zone->active_servers('v6')) {
            @$entries = shuffle(@$entries);

            # for now just put all IPv6 servers in the '2' zone
            (my $pgeodns_group = "2.${name}") =~ s/\.$//;
            push @{$pgeodns->{data}->{$pgeodns_group}->{aaaa}}, $_ for @$entries;
        }

    }

    close $fh or die "could not close $file.tmp: $!";
    rename "$file.tmp", "$file.tinydns"
      or die "could not rename $file.tmp to $file.tinydns: $!";

    my $json = JSON::XS->new->pretty->utf8;
    my $js   = $json->encode($pgeodns);
    my $file = "$ENV{CBROOTLOCAL}/dns/$pool_domain.json";
    open(my $js_fh, ">$file.tmp") or die "Could not open $file.tmp: $!";
    print $js_fh $js;
    close $js_fh or die "could not close $file.json.tmp: $!";
    rename "$file.tmp", "$file"
      or die "could not rename $file.tmp to $file: $!";

}
else {
    die "Unknown command: $cmd\n";
}

#$db->commit() or die "Error on commit\n";
$SIG{__DIE__} = 'DEFAULT';
$db->disconnect();