pool

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

my $config     = Combust::Config->new;
my $config_ntp = $config->site->{ntppool};

use NP::Model;

my $pool_domain = $config_ntp->{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_local {
    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 ntpdate {
    my ($host, $error) = @_;

    my $js = get("https://trace2.ntppool.org/ntp/$host");

    my $json = JSON::XS->new->utf8;
    my %ntp  = %{$json->decode($js)};

    #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";
        warn Data::Dumper->Dump([\%ntp]);
        return undef;
    }

    return 1;
}

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 $geoip = $ENV{geoip_service} || 'geoip';
    my $country = get("http://${geoip}/api/country?ip=" . $server->ip);
    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";

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 ($ip = Net::IP->new($hostname)) {
        $ip       = $ip->ip();
        $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;
}
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(
        name       => "",
        config     => "",
        created_on => DateTime->now,
        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, created_on)
                      select ?, id, score_raw, NOW() 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) {
        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);
    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);
    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 "zone") {

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

    my $roots = NP::Model->dns_root->get_objects;
    for my $root (@$roots) {

        # TODO:
        #   Make NP::DNS::Root optionally limit how many IPs per zone

        $root->populate;

        if ($root->origin =~ m{\.{2}} or $root->origin =~ m/[^a-z\.-]/) {
            warn "Invalid zone name: " . $root->origin . "\n";
            next;
        }
        my $json = JSON::XS->new->pretty->utf8->convert_blessed;
        my $js   = $json->encode($root);
        my $file = "$ENV{CBROOTLOCAL}/dns/" . $root->origin . ".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();