#!/usr/bin/env perl

#

# host_manager.pl - Minimal host registry web app with no CPAN dependencies.

#

use strict;

use warnings;

use Cwd qw(abs_path);

use File::Basename qw(dirname);

use File::Path qw(make_path);

use IO::Socket::INET;

use POSIX qw(strftime);

use Time::HiRes qw(time);

my $script_dir = dirname(abs_path($0));

my $project_dir = dirname($script_dir);

my %opt = (

    bind => $ENV{HOST_MANAGER_BIND} || '127.0.0.1',

    port => $ENV{HOST_MANAGER_PORT} || 8088,

    local_hosts_tsv => $ENV{HOST_MANAGER_LOCAL_HOSTS_TSV} || "$project_dir/config/local-hosts.tsv",

while (@ARGV) {

    my $arg = shift @ARGV;

    if ($arg eq '--bind') {

        $opt{bind} = shift @ARGV;

    } elsif ($arg eq '--port') {

        $opt{port} = shift @ARGV;

        $opt{db} = shift @ARGV;

        $opt{data} = shift @ARGV;

    } elsif ($arg eq '--local-hosts-tsv') {

        $opt{local_hosts_tsv} = shift @ARGV;

        $opt{work_orders} = shift @ARGV;

        usage();

        exit 0;

    } else {

        die "Unknown option: $arg\n";

    }

}

my $session_secret = $ENV{HOST_MANAGER_SESSION_SECRET} || random_hex(32);

my %sessions;

my $server = IO::Socket::INET->new(

    LocalHost => $opt{bind},

    LocalPort => $opt{port},

    Proto => 'tcp',

    Listen => 10,

    ReuseAddr => 1,

) or die "Cannot listen on $opt{bind}:$opt{port}: $!\n";

print "host-manager listening on http://$opt{bind}:$opt{port}\n";

print "seed/export hosts file: $opt{data}\n";

while (my $client = $server->accept) {

    eval {

        $client->autoflush(1);

        handle_client($client);

    };

    if ($@) {

        eval { send_json($client, 500, { error => 'internal_error', detail => "$@" }); };

    }

    close $client;

}

sub usage {

    print <<"EOF";

Usage: perl scripts/host_manager.pl [--bind 127.0.0.1] [--port 8088]

Environment:

  HOST_MANAGER_TOTP_SECRET      Base32 TOTP secret required for write access.

  HOST_MANAGER_SESSION_SECRET   Optional session signing secret.

  HOST_MANAGER_LOCAL_HOSTS_TSV  Defaults to config/local-hosts.tsv.

download/export compatibility artifacts. The nginx vhost keeps registry, CA,

work order and download endpoints behind OTP.

}

sub handle_client {

    my ($client) = @_;

    my $request_line = <$client>;

    return unless defined $request_line;

    $request_line =~ s/\r?\n$//;

    my ($method, $target) = $request_line =~ m{^([A-Z]+)\s+(\S+)\s+HTTP/};

    return send_text($client, 400, 'bad request') unless $method && $target;

    my %headers;

    while (my $line = <$client>) {

        $line =~ s/\r?\n$//;

        last if $line eq '';

        my ($k, $v) = split /:\s*/, $line, 2;

        $headers{lc $k} = $v if defined $k && defined $v;

    }

    my $body = '';

    if (($headers{'content-length'} || 0) > 0) {

        read($client, $body, int($headers{'content-length'}));

    }

    my ($path, $query) = split /\?/, $target, 2;

    my %query = parse_params($query || '');

    }

    if ($method eq 'GET' && $path eq '/healthz') {

    if ($method eq 'GET' && $path eq '/api/session') {

        return send_json($client, 200, { authenticated => is_authenticated(\%headers) ? json_bool(1) : json_bool(0) });

    }

        return send_json($client, 503, { error => 'otp_not_configured' }) unless $ENV{HOST_MANAGER_TOTP_SECRET};

        my $payload = request_payload(\%headers, $body);

        my $otp = $payload->{otp} || '';

        if (!verify_totp($ENV{HOST_MANAGER_TOTP_SECRET} || '', $otp)) {

            return send_json($client, 401, { error => 'invalid_otp' });

        }

        my $token = create_session();

        return send_json($client, 200, { ok => json_bool(1) }, [ "Set-Cookie: hm_session=$token; HttpOnly; SameSite=Strict; Path=/" ]);

    }

    if ($method eq 'POST' && $path eq '/api/logout') {

        expire_session(\%headers);

        return send_json($client, 200, { ok => json_bool(1) }, [ "Set-Cookie: hm_session=deleted; Max-Age=0; Path=/" ]);

    }

    return send_json($client, 401, { error => 'authentication_required' }) unless is_authenticated(\%headers);

        my $registry = load_registry();

        return send_json($client, 200, registry_payload($registry));

    }

        return send_json($client, 200, work_orders_payload(load_work_orders()));

    }

        return send_json($client, 200, debug_database_tables_payload());

    }

    if ($method eq 'GET' && $path eq '/api/debug/database/table') {

        return send_json($client, 200, debug_database_table_payload($query{name} || $query{table} || '', $query{limit} || 100));

    }

        my $export = debug_database_table_export_payload($query{name} || $query{table} || '');

        return send_json($client, 400, { error => $export->{error} }) if $export->{error};

        return send_download($client, 200, json_encode($export), 'application/json; charset=utf-8', debug_table_export_filename($export->{table}, 'json'));

    }

    if ($method eq 'GET' && $path eq '/download/debug/database/table.csv') {

        my $export = debug_database_table_export_payload($query{name} || $query{table} || '');

        return send_json($client, 400, { error => $export->{error} }) if $export->{error};

        return send_download($client, 200, render_debug_table_csv($export), 'text/csv; charset=utf-8', debug_table_export_filename($export->{table}, 'csv'));

    }

        return send_download($client, 200, render_hosts_yaml($registry), 'application/x-yaml; charset=utf-8', 'hosts.yaml');

    if ($method eq 'GET' && $path eq '/download/local-hosts.tsv') {

        my $registry = load_registry();

        return send_download($client, 200, render_local_hosts_tsv($registry), 'text/tab-separated-values; charset=utf-8', 'local-hosts.tsv');

    }

    if ($method eq 'GET' && $path eq '/download/monitoring.json') {

        my $registry = load_registry();

        return send_download($client, 200, json_encode(render_monitoring($registry)), 'application/json; charset=utf-8', 'monitoring-hosts.json');

    }

        return send_json_raw($client, 200, ca_manager_json('status-json'));

    }

    if ($method eq 'GET' && $path eq '/api/ca/certificates') {

        return send_json_raw($client, 200, ca_manager_json('list-json'));

    }

    if ($method eq 'GET' && $path eq '/download/ca.crt') {

        return send_file($client, ca_cert_path(), 'application/x-pem-file; charset=utf-8', 'xdev-madagascar-host-ca.crt');

    }

        my $name = $1;

        return send_file($client, ca_issued_cert_path($name), 'application/x-pem-file; charset=utf-8', "$name.crt");

    }

        my $name = $1;

        return send_file($client, ca_issued_key_path($name), 'application/x-pem-file; charset=utf-8', "$name.key");

    }

    if ($method eq 'POST' && $path =~ m{^/api/}) {

        if ($path eq '/api/hosts/upsert') {

            my $payload = request_payload(\%headers, $body);

            return upsert_host($client, $payload);

        }

        if ($path eq '/api/hosts/delete') {

            my $payload = request_payload(\%headers, $body);

            return delete_host($client, $payload->{id} || '');

        }

            my $payload = request_payload(\%headers, $body);

            return reassign_vhost($client, $payload);

        }

            my $payload = request_payload(\%headers, $body);

            return upsert_vhost($client, $payload);

        }

        if ($path eq '/api/vhosts/delete') {

            my $payload = request_payload(\%headers, $body);

            return delete_vhost($client, $payload);

        }

            my $payload = request_payload(\%headers, $body);

            return set_vhost_certificate($client, $payload);

        }

        if ($path eq '/api/vhosts/issue-certificate') {

            my $payload = request_payload(\%headers, $body);

            return issue_vhost_certificate($client, $payload);

        }

            my $payload = request_payload(\%headers, $body);

            return confirm_work_order($client, $payload);

        }

            my $payload = request_payload(\%headers, $body);

            return update_work_order_checklist($client, $payload);

        }

            my $registry = load_registry();

            my $content = render_local_hosts_tsv($registry);

            backup_file($opt{local_hosts_tsv});

            write_file($opt{local_hosts_tsv}, $content);

            return send_json($client, 200, { ok => json_bool(1), file => $opt{local_hosts_tsv} });

        }

    }

    return send_json($client, 404, { error => 'not_found' });

}

    my ($path) = @_;

    return $registry;

sub save_registry {

    my ($registry) = @_;

    $registry->{updated_at} = iso_now();

sub save_work_orders {

    my ($orders) = @_;

sub work_orders_payload {

    my ($orders) = @_;

    my $pending = 0;

    for my $wo (@{ $orders->{work_orders} || [] }) {

        $pending++ if ($wo->{status} || 'pending') eq 'pending';

    }

    return {

        version => $orders->{version},

        work_orders => $orders->{work_orders} || [],

        counts => {

            work_orders => scalar @{ $orders->{work_orders} || [] },

            pending => $pending,

        },

    };

}

sub confirm_work_order {

    my ($client, $payload) = @_;

    my $id = clean_scalar($payload->{id} || '');

    return send_json($client, 400, { error => 'invalid_work_order_id' }) unless $id =~ /\AWO-[A-Za-z0-9_.-]+\z/;

    return send_json($client, 400, { error => 'confirmation_required' }) unless clean_scalar($payload->{confirm} || '') eq $id;

    my $orders = load_work_orders();

    my $work_order;

    for my $wo (@{ $orders->{work_orders} || [] }) {

        if (($wo->{id} || '') eq $id) {

            $work_order = $wo;

            last;

        }

    }

    return send_json($client, 404, { error => 'work_order_not_found' }) unless $work_order;

    return send_json($client, 409, { error => 'work_order_not_pending' }) unless ($work_order->{status} || 'pending') eq 'pending';

    return send_json($client, 409, {

        error => 'work_order_incomplete',

        incomplete => $incomplete,

    }) if @$incomplete;

    my $registry = load_registry();

    my $results = apply_work_order($registry, $work_order);

    $work_order->{status} = 'confirmed';

    $work_order->{confirmed_at} = iso_now();

    $work_order->{result} = scalar(@$results) . ' action(s) applied';

    save_registry($registry);

    save_work_orders($orders);

    backup_file($opt{local_hosts_tsv});

    write_file($opt{local_hosts_tsv}, render_local_hosts_tsv($registry));

    return send_json($client, 200, {

        ok => json_bool(1),

        work_order => $work_order,

        results => $results,

        local_hosts_tsv => $opt{local_hosts_tsv},

    });

}

    my ($client, $payload) = @_;

    my $id = clean_scalar($payload->{id} || '');

    my $item_id = clean_scalar($payload->{item_id} || '');

    my $status = clean_scalar($payload->{status} || '');

    my $notes = clean_scalar($payload->{notes} || '');

    return send_json($client, 400, { error => 'invalid_work_order_id' }) unless $id =~ /\AWO-[A-Za-z0-9_.-]+\z/;

    return send_json($client, 400, { error => 'invalid_checklist_item' }) unless $item_id =~ /\A[A-Za-z0-9_.-]+\z/;

    return send_json($client, 400, { error => 'invalid_checklist_status' }) unless $status =~ /\A(?:pending|done|blocked)\z/;

    my $orders = load_work_orders();

    my $work_order;

    for my $wo (@{ $orders->{work_orders} || [] }) {

        if (($wo->{id} || '') eq $id) {

            $work_order = $wo;

            last;

        }

    }

    return send_json($client, 404, { error => 'work_order_not_found' }) unless $work_order;

    return send_json($client, 409, { error => 'work_order_not_pending' }) unless ($work_order->{status} || 'pending') eq 'pending';

    my $item;

    for my $candidate (@{ $work_order->{checklist} || [] }) {

        if (($candidate->{id} || '') eq $item_id) {

            $item = $candidate;

            last;

        }

    }

    return send_json($client, 404, { error => 'checklist_item_not_found' }) unless $item;

    $item->{status} = $status;

    $item->{updated_at} = iso_now();

    $item->{notes} = $notes if length $notes;

    save_work_orders($orders);

    return send_json($client, 200, { ok => json_bool(1), work_order => $work_order });

}

sub incomplete_work_order_items {

    my ($work_order) = @_;

    my @incomplete;

    for my $item (@{ $work_order->{checklist} || [] }) {

        push @incomplete, $item unless ($item->{status} || 'pending') eq 'done';

    }

    return \@incomplete;

}

    my ($registry, $work_order) = @_;

    my @results;

    for my $action (@{ $work_order->{actions} || [] }) {

        my $type = $action->{type} || '';

        if ($type eq 'remove_name') {

            my $host_id = $action->{host_id} || '';

            my $name = $action->{name} || '';

            my $removed = 0;

            for my $host (@{ $registry->{hosts} || [] }) {

                next unless ($host->{id} || '') eq $host_id;

                my @kept_vhosts = grep { $_ ne $name } declared_vhost_names($host);

                $removed = (@kept_aliases != @{ $host->{aliases} || [] }) || (@kept_vhosts != @{ $host->{vhosts} || [] });

                $host->{aliases} = \@kept_aliases;

                $host->{vhosts} = \@kept_vhosts;

            }

            push @results, {

                type => $type,

                host_id => $host_id,

                name => $name,

                removed => json_bool($removed),

            };

        } else {

            die "Unsupported work order action: $type\n";

        }

    }

    return \@results;

}

    my ($registry) = @_;

    my $problems = analyze_hosts($registry->{hosts});

    my @vhosts = vhost_payloads($dbh);

    my @certificates = certificate_payloads($dbh);

        version => $registry->{version},

        updated_at => $registry->{updated_at},

        policy => $registry->{policy},

        certificates => \@certificates,

        counts => {

            hosts => scalar @{ $registry->{hosts} },

        },

    };

}

    my ($dbh) = @_;

    my @rows;

    my $sth = $dbh->prepare(<<'SQL');

SELECT

    v.vhost_fqdn,

    v.host_fqdn,

    v.status AS vhost_status,

    v.certificate_id,

    h.legacy_id,

    h.hosts_ip,

    h.dns_ip,

    h.monitoring,

    h.status AS host_status,

    c.common_name,

    c.not_after,

    c.fingerprint_sha256,

    c.status AS certificate_status

FROM vhosts v

JOIN hosts h ON h.fqdn = v.host_fqdn

LEFT JOIN certificates c ON c.certificate_id = v.certificate_id

WHERE v.status = 'active'

ORDER BY v.vhost_fqdn

SQL

    $sth->execute;

    while (my $row = $sth->fetchrow_hashref) {

        my $cert_id = clean_scalar($row->{certificate_id} || '');

        my %certificate = $cert_id ? (

            id => $cert_id,

            name => $cert_id,

            common_name => clean_scalar($row->{common_name} || ''),

            status => clean_scalar($row->{certificate_status} || ''),

            not_after => clean_scalar($row->{not_after} || ''),

            fingerprint_sha256 => clean_scalar($row->{fingerprint_sha256} || ''),

            has_private_key => json_bool(-f ca_issued_key_path($cert_id) ? 1 : 0),

        ) : ();

        push @rows, {

            vhost => $row->{vhost_fqdn},

            vhost_fqdn => $row->{vhost_fqdn},

            host_id => $row->{legacy_id} || '',

            host_fqdn => $row->{host_fqdn},

            ip => $row->{hosts_ip} || $row->{dns_ip} || '',

            derived_aliases => short_alias_for_fqdn($row->{vhost_fqdn}) ? [ short_alias_for_fqdn($row->{vhost_fqdn}) ] : [],

            monitoring => $row->{monitoring} || '',

            status => $row->{host_status} || $row->{vhost_status} || '',

            vhost_status => $row->{vhost_status} || '',

            certificate_id => $cert_id,

            certificate => $cert_id ? \%certificate : undef,

        };

    }

    return @rows;

}

sub certificate_payloads {

    my ($dbh) = @_;

    my @certificates;

    my $sth = $dbh->prepare('SELECT * FROM certificates WHERE status <> ? ORDER BY certificate_id');

    $sth->execute('retired');

    while (my $row = $sth->fetchrow_hashref) {

        my $id = clean_scalar($row->{certificate_id} || '');

        next unless $id;

        push @certificates, {

            id => $id,

            name => $id,

            host_fqdn => $row->{host_fqdn} || '',

            common_name => $row->{common_name} || '',

            subject => $row->{subject} || '',

            issuer => $row->{issuer} || '',

            serial => $row->{serial} || '',

            status => $row->{status} || '',

            not_before => $row->{not_before} || '',

            not_after => $row->{not_after} || '',

            fingerprint_sha256 => $row->{fingerprint_sha256} || '',

            dns_names => [ certificate_dns_names($dbh, $id) ],

            has_private_key => json_bool(-f ca_issued_key_path($id) ? 1 : 0),

        };

    }

    return @certificates;

}

sub certificate_dns_names {

    my ($dbh, $certificate_id) = @_;

    my @names;

    my $sth = $dbh->prepare('SELECT dns_name FROM certificate_dns_names WHERE certificate_id = ? ORDER BY dns_name');

    $sth->execute($certificate_id);

    while (my ($name) = $sth->fetchrow_array) {

        push @names, $name;

    }

    return @names;

}

    my ($client, $payload) = @_;

    my $id = clean_id($payload->{id} || '');

    return send_json($client, 400, { error => 'invalid_id' }) unless $id;

    return send_json($client, 400, { error => 'missing_ip' }) unless $ip;

    return send_json($client, 400, { error => 'missing_fqdn' }) unless $fqdn;

    my @aliases = clean_alias_names($payload);

    my $registry = load_registry();

    my @vhosts = defined $payload->{vhosts}

        ? clean_vhost_names($payload)

        : ($existing_host ? declared_vhost_names($existing_host) : ());

        id => $id,

        aliases => \@aliases,

        vhosts => \@vhosts,

        sources => [ clean_list($payload->{sources}) ],

        monitoring => clean_scalar($payload->{monitoring} || 'pending'),

        notes => clean_scalar($payload->{notes} || ''),

    );

        my $replaced = 0;

        for my $i (0 .. $#{ $registry->{hosts} }) {

            if ($registry->{hosts}->[$i]{id} eq $id) {

                $registry->{hosts}->[$i] = \%host;

                $replaced = 1;

                last;

            }

        save_registry($registry);

        1;

    };

    if (!$response) {

        my $err = $@ || 'upsert_failed';

        return send_json($client, 409, { error => 'alias_conflict', detail => clean_scalar($err) })

            if $err =~ /alias_conflict:/;

        die $err;

    return send_json($client, 200, { ok => json_bool(1), host => \%host });

}

sub delete_host {

    my ($client, $id) = @_;

    $id = clean_id($id);

    return send_json($client, 400, { error => 'invalid_id' }) unless $id;

    my $registry = load_registry();

    my @kept = grep { $_->{id} ne $id } @{ $registry->{hosts} };

    return send_json($client, 404, { error => 'not_found' }) if @kept == @{ $registry->{hosts} };

    $registry->{hosts} = \@kept;

    save_registry($registry);

    return send_json($client, 200, { ok => json_bool(1) });

}

    my ($client, $payload) = @_;

    my $vhost = normalize_dns_name($payload->{vhost_fqdn} || '');

    my $target_fqdn = normalize_dns_name($payload->{host_fqdn} || $payload->{fqdn} || '');

    return send_json($client, 400, { error => 'invalid_vhost' }) unless name_is_vhost($vhost);

    return send_json($client, 400, { error => 'missing_target_host' }) unless $target_fqdn;

    my $dbh = dbh();

    my ($current_fqdn) = $dbh->selectrow_array(

        "SELECT host_fqdn FROM vhosts WHERE vhost_fqdn = ? AND status = 'active'",

        undef,

        $vhost,

    );

    return send_json($client, 404, { error => 'vhost_not_found' }) unless $current_fqdn;

    return send_json($client, 400, { error => 'invalid_target_host' }) unless db_scalar($dbh, 'SELECT COUNT(*) FROM hosts WHERE fqdn = ? AND status <> ?', $target_fqdn, 'retired');

    return send_json($client, 200, { ok => json_bool(1), vhost_fqdn => $vhost, host_fqdn => $current_fqdn }) if $current_fqdn eq $target_fqdn;

    my $result = eval {

        with_transaction($dbh, sub {

            my $now = iso_now();

            $dbh->do(

                "UPDATE vhosts SET host_fqdn = ?, updated_at = ?, status = 'active' WHERE vhost_fqdn = ?",

                undef,

                $target_fqdn, $now, $vhost,

            );

            my $registry = load_registry_from_db();

            my ($target_host) = grep { ($_->{fqdn} || '') eq $target_fqdn } @{ $registry->{hosts} || [] };

            my ($current_host) = grep { ($_->{fqdn} || '') eq $current_fqdn } @{ $registry->{hosts} || [] };

            upsert_host_to_db($dbh, $target_host) if $target_host;

            upsert_host_to_db($dbh, $current_host) if $current_host;

        1;

    };

    if (!$result) {

        my $err = $@ || 'vhost_reassign_failed';

        return send_json($client, 409, { error => 'vhost_reassign_failed', detail => clean_scalar($err) });

    }

    return send_json($client, 200, { ok => json_bool(1), vhost_fqdn => $vhost, host_fqdn => $target_fqdn, previous_host_fqdn => $current_fqdn });

}

    my ($client, $payload) = @_;

    my $vhost = normalize_dns_name($payload->{vhost_fqdn} || '');

    my $target_fqdn = normalize_dns_name($payload->{host_fqdn} || $payload->{fqdn} || '');

    return send_json($client, 400, { error => 'invalid_vhost' }) unless name_is_vhost($vhost);

    return send_json($client, 400, { error => 'missing_target_host' }) unless $target_fqdn;

    my $dbh = dbh();

    return send_json($client, 400, { error => 'invalid_target_host' }) unless db_scalar($dbh, 'SELECT COUNT(*) FROM hosts WHERE fqdn = ? AND status <> ?', $target_fqdn, 'retired');

    my ($current_fqdn) = $dbh->selectrow_array(

        "SELECT host_fqdn FROM vhosts WHERE vhost_fqdn = ? AND status = 'active'",

        undef,

        $vhost,

    );

    my $result = eval {

        with_transaction($dbh, sub {

            my $now = iso_now();

            upsert_vhost_to_db($dbh, $target_fqdn, $vhost, $now);

            my $registry = load_registry_from_db();

            my ($target_host) = grep { ($_->{fqdn} || '') eq $target_fqdn } @{ $registry->{hosts} || [] };

            my ($current_host) = grep { ($_->{fqdn} || '') eq ($current_fqdn || '') } @{ $registry->{hosts} || [] };

            upsert_host_to_db($dbh, $target_host) if $target_host;

            upsert_host_to_db($dbh, $current_host) if $current_host && ($current_fqdn || '') ne $target_fqdn;

            set_schema_meta($dbh, 'registry_updated_at', iso_now());

        });

        1;

    };

    if (!$result) {

        my $err = $@ || 'vhost_upsert_failed';

        return send_json($client, 409, { error => 'vhost_upsert_failed', detail => clean_scalar($err) });

    }

    return send_json($client, 200, { ok => json_bool(1), vhost_fqdn => $vhost, host_fqdn => $target_fqdn, previous_host_fqdn => $current_fqdn || '' });

}

sub delete_vhost {

    my ($client, $payload) = @_;

    my $vhost = normalize_dns_name($payload->{vhost_fqdn} || '');

    my $confirm = normalize_dns_name($payload->{confirm} || '');

    return send_json($client, 400, { error => 'invalid_vhost' }) unless name_is_vhost($vhost);

    return send_json($client, 400, { error => 'confirmation_required' }) unless $confirm eq $vhost;

    my $dbh = dbh();

    my ($current_fqdn) = $dbh->selectrow_array(

        "SELECT host_fqdn FROM vhosts WHERE vhost_fqdn = ? AND status = 'active'",

        undef,

        $vhost,

    );

    return send_json($client, 404, { error => 'vhost_not_found' }) unless $current_fqdn;

    my $result = eval {

        with_transaction($dbh, sub {

            my $now = iso_now();

            $dbh->do(

                "UPDATE vhosts SET status = 'retired', updated_at = ? WHERE vhost_fqdn = ? AND status = 'active'",

                undef,

                $now, $vhost,

            );

            my $registry = load_registry_from_db();

            my ($current_host) = grep { ($_->{fqdn} || '') eq $current_fqdn } @{ $registry->{hosts} || [] };

            upsert_host_to_db($dbh, $current_host) if $current_host;

            set_schema_meta($dbh, 'registry_updated_at', iso_now());

        });

        1;

    };

    if (!$result) {

        my $err = $@ || 'vhost_delete_failed';

        return send_json($client, 409, { error => 'vhost_delete_failed', detail => clean_scalar($err) });

    }

    return send_json($client, 200, { ok => json_bool(1), vhost_fqdn => $vhost, previous_host_fqdn => $current_fqdn });

}

    my ($client, $payload) = @_;

    my $vhost = normalize_dns_name($payload->{vhost_fqdn} || '');

    my $raw_certificate_id = clean_scalar($payload->{certificate_id} || $payload->{cert_id} || '');

    my $certificate_id = clean_certificate_id($raw_certificate_id);

    return send_json($client, 400, { error => 'invalid_vhost' }) unless name_is_vhost($vhost);

    return send_json($client, 400, { error => 'invalid_certificate' })

        if length($raw_certificate_id) && !length($certificate_id);

    my $dbh = dbh();

    return send_json($client, 404, { error => 'vhost_not_found' })

        unless db_scalar($dbh, "SELECT COUNT(*) FROM vhosts WHERE vhost_fqdn = ? AND status = 'active'", $vhost);

    if (length $certificate_id) {

        return send_json($client, 400, { error => 'invalid_certificate' })

            unless db_scalar($dbh, "SELECT COUNT(*) FROM certificates WHERE certificate_id = ? AND status <> 'retired'", $certificate_id);

    }

    my $now = iso_now();

    $dbh->do(

        'UPDATE vhosts SET certificate_id = ?, tls_mode = ?, updated_at = ? WHERE vhost_fqdn = ? AND status = ?',

        undef,

        length($certificate_id) ? $certificate_id : undef,

        length($certificate_id) ? 'local-ca' : 'none',

        $now,

        $vhost,

        'active',

    );

    set_schema_meta($dbh, 'registry_updated_at', $now);

    return send_json($client, 200, { ok => json_bool(1), vhost_fqdn => $vhost, certificate_id => $certificate_id });

}

sub issue_vhost_certificate {

    my ($client, $payload) = @_;

    my $vhost = normalize_dns_name($payload->{vhost_fqdn} || '');

    return send_json($client, 400, { error => 'invalid_vhost' }) unless name_is_vhost($vhost);

    my $dbh = dbh();

    my ($host_fqdn) = $dbh->selectrow_array(

        "SELECT host_fqdn FROM vhosts WHERE vhost_fqdn = ? AND status = 'active'",

        undef,

        $vhost,

    );

    return send_json($client, 404, { error => 'vhost_not_found' }) unless $host_fqdn;

    my @dns_names = unique_preserve(grep { length $_ } ($vhost, short_alias_for_fqdn($vhost)));

    my $certificate_id = clean_certificate_id($vhost . '-' . strftime('%Y%m%d%H%M%S', localtime));

    my $issued = eval {

        ca_manager_output('issue', $certificate_id, @dns_names);

        ca_manager_json('list-json');

        with_transaction($dbh, sub {

            my $now = iso_now();

            $dbh->do(

                "UPDATE vhosts SET certificate_id = ?, tls_mode = 'local-ca', updated_at = ? WHERE vhost_fqdn = ? AND status = 'active'",

                undef,

                $certificate_id,

                $now,

                $vhost,

            );

            set_schema_meta($dbh, 'registry_updated_at', $now);

        });

        1;

    };

    if (!$issued) {

        return send_json($client, 409, { error => 'certificate_issue_failed', detail => clean_scalar($@ || '') });

    }

    my ($cert) = grep { ($_->{id} || '') eq $certificate_id } certificate_payloads($dbh);

    return send_json($client, 200, {

        ok => json_bool(1),

        vhost_fqdn => $vhost,

        host_fqdn => $host_fqdn,

        certificate_id => $certificate_id,

        certificate => $cert || { id => $certificate_id, name => $certificate_id, dns_names => \@dns_names },

    });

}

    my ($hosts) = @_;

    my @problems;

    my (%names, %ids);

    for my $host (@$hosts) {

        push @problems, problem($host, 'duplicate-id', "Duplicate id $host->{id}") if $ids{ $host->{id} }++;

        push @problems, problem($host, 'missing-fqdn', 'No madagascar.xdev.ro FQDN') unless ($fqdn =~ /\.madagascar\.xdev\.ro$/) || ($host->{status} || '') ne 'active';

        my @declared = declared_dns_names($host);

        for my $name (@declared) {

        }

        for my $derived (derived_alias_names($host), derived_vhost_alias_names($host)) {

                if $declared{$derived};

        }

            unless canonical_ip($host) || ($host->{status} || '') ne 'active';

    return \@problems;

}

    my ($host) = @_;

    my %copy = %$host;

    $copy{ip} = canonical_ip($host);

    $copy{aliases} = [ declared_alias_names($host) ];

    $copy{derived_aliases} = [ derived_alias_names($host) ];

    $copy{vhosts} = [ declared_vhost_names($host) ];

    $copy{derived_vhost_aliases} = [ derived_vhost_alias_names($host) ];

}

sub effective_names {

    my ($host) = @_;

    push @names, derived_alias_names($host), derived_vhost_alias_names($host);

}

    my ($host) = @_;

    my @names;

    my $fqdn = canonical_host_fqdn($host);

    push @names, $fqdn if length $fqdn;

    push @names, declared_alias_names($host);

    push @names, declared_vhost_names($host);

    return unique_preserve(@names);

}

sub declared_alias_names {

    my ($host) = @_;

    return unique_preserve(map { normalize_dns_name($_) } @{ $host->{aliases} || [] });

}

sub declared_vhost_names {

    my ($host) = @_;

    return unique_preserve(map { normalize_dns_name($_) } @{ $host->{vhosts} || [] });

}

sub declared_dns_names_legacy {

    my ($host) = @_;

    return map { normalize_dns_name($_) } @{ $host->{names} || [] };

}

sub split_legacy_names {

    my ($id, $names) = @_;

    my $fallback = clean_id($id || '');

    my (%result) = (

        fqdn => '',

        aliases => [],

        vhosts => [],

    );

    for my $name (map { normalize_dns_name($_) } @$names) {

        next unless length $name;

        if (!$result{fqdn} && $name =~ /\.madagascar\.xdev\.ro\z/ && !name_is_vhost($name)) {

            $result{fqdn} = $name;

            next;

        }

        if (!$result{fqdn} && $name =~ /\./ && !name_is_vhost($name)) {

            $result{fqdn} = $name;

            next;

        }

        if (name_is_vhost($name)) {

            push @{ $result{vhosts} }, $name;

        } else {

            push @{ $result{aliases} }, $name;

        }

    }

    $result{fqdn} ||= $fallback ? "$fallback.madagascar.xdev.ro" : '';

    $result{aliases} = [ unique_preserve(grep { $_ ne $result{fqdn} } @{ $result{aliases} }) ];

    $result{vhosts} = [ unique_preserve(@{ $result{vhosts} }) ];

    return \%result;

}

sub derived_alias_names {

    my @derived;

    push @derived, short_alias_for_fqdn($fqdn) if length $fqdn;

    for my $name (declared_alias_names($host)) {

        push @derived, short_alias_for_fqdn($name);

    }

    return unique_preserve(grep { length $_ } @derived);

}

sub derived_vhost_alias_names {

    my ($host) = @_;

    my @derived;

    for my $name (declared_vhost_names($host)) {

        push @derived, short_alias_for_fqdn($name);

}

sub clean_alias_names {

    my ($payload) = @_;

    return clean_name_bucket($payload->{aliases})

        if defined $payload->{aliases};

    my @legacy = remove_derived_names(clean_list($payload->{names}));

    return grep { !name_is_vhost($_) && $_ ne canonical_host_fqdn({ %$payload, names => \@legacy }) } @legacy;

}

sub clean_vhost_names {

    my ($payload) = @_;

    return clean_name_bucket($payload->{vhosts})

        if defined $payload->{vhosts};

    my @legacy = remove_derived_names(clean_list($payload->{names}));

    return grep { name_is_vhost($_) } @legacy;

}

sub clean_name_bucket {

    my ($value) = @_;

    my @names = clean_list($value);

    return unique_preserve(map { normalize_dns_name($_) } remove_derived_names(@names));

sub remove_derived_names {

    my @names = @_;

    my %derived;

    for my $name (@names) {

        next unless $name =~ /^(.+)\.madagascar\.xdev\.ro$/;

        $derived{$1} = 1;

    }

    return grep { !$derived{$_} } @names;

}

sub unique_preserve {

    my @values = @_;

    my %seen;

    return grep { !$seen{$_}++ } @values;

}

    my ($host) = @_;

    return '' unless $host && ref($host) eq 'HASH';

    for my $key (qw(ip dns_ip hosts_ip)) {

        my $value = clean_scalar($host->{$key} || '');

        return $value if length $value;

    }

    return '';

}

    my ($host, $code, $message) = @_;

    return { host_id => $host->{id}, code => $code, message => $message };

}

sub render_local_hosts_tsv {

    my ($registry) = @_;

    my $out = "# Local DNS manifest for the madagascar network.\n";

    $out .= "# Format:\n";

    $out .= "# Priority rule:\n";

    $out .= "# - DHCP lease/reservation on 192.168.2.1 is canonical for LAN IP allocation.\n";

    $out .= "# - madagascar.json is canonical for cluster roles and service interfaces.\n";

    $out .= "# - This file publishes approved local DNS records derived from those sources.\n";

    for my $host (sort { $a->{id} cmp $b->{id} } @{ $registry->{hosts} }) {

        next unless ($host->{status} || 'active') eq 'active';

        next unless $ip;

        next unless @names;

    return $out;

}

sub render_monitoring {

    my ($registry) = @_;

    my @hosts;

    for my $host (sort { $a->{id} cmp $b->{id} } @{ $registry->{hosts} }) {

        next unless ($host->{status} || 'active') eq 'active';

        next if ($host->{monitoring} || 'pending') eq 'disabled';

            id => $host->{id},

            declared_names => [ declared_dns_names($host) ],

            aliases_declared => [ declared_alias_names($host) ],

            aliases_derived => [ derived_alias_names($host) ],

            vhosts_declared => [ declared_vhost_names($host) ],

            vhost_aliases_derived => [ derived_vhost_alias_names($host) ],

            monitoring => $host->{monitoring} || 'pending',

            notes => $host->{notes} || '',

        };

    }

    return {

        version => $registry->{version},

        generated_at => iso_now(),

    };

}

    my $dbh = dbh();

    my @tables;

    my $sth = $dbh->prepare("SELECT name FROM sqlite_master WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY name");

    $sth->execute;

    while (my ($name) = $sth->fetchrow_array) {

        my $quoted = $dbh->quote_identifier($name);

        my ($count) = $dbh->selectrow_array("SELECT COUNT(*) FROM $quoted");

        push @tables, {

            name => $name,

            rows => int($count || 0),

        };

    }

    return {

        database => $opt{db},

        generated_at => iso_now(),

        tables => \@tables,

        counts => {

            tables => scalar @tables,

            rows => sum(map { $_->{rows} } @tables),

        },

    };

}

sub debug_database_table_payload {

    my ($table, $limit) = @_;

    my $dbh = dbh();

    $table = clean_scalar($table);

    return { error => 'missing_table' } unless length $table;

    return { error => 'invalid_table' } unless debug_table_exists($dbh, $table);

    $limit = int($limit || 100);

    $limit = 1 if $limit < 1;

    $limit = 500 if $limit > 500;

    my $quoted = $dbh->quote_identifier($table);

    my $columns = $dbh->selectall_arrayref("PRAGMA table_info($quoted)", { Slice => {} }) || [];

    my $indexes = $dbh->selectall_arrayref("PRAGMA index_list($quoted)", { Slice => {} }) || [];

    my @index_details;

    for my $index (@$indexes) {

        my $index_name = $index->{name} || '';

        next unless length $index_name;

        my $quoted_index = $dbh->quote_identifier($index_name);

        my $index_columns = $dbh->selectall_arrayref("PRAGMA index_info($quoted_index)", { Slice => {} }) || [];

        push @index_details, {

            name => $index_name,

            unique => int($index->{unique} || 0),

            origin => $index->{origin} || '',

            partial => int($index->{partial} || 0),

            columns => [ map { $_->{name} || '' } @$index_columns ],

        };

    }

    my $foreign_keys = $dbh->selectall_arrayref("PRAGMA foreign_key_list($quoted)", { Slice => {} }) || [];

    my ($row_count) = $dbh->selectrow_array("SELECT COUNT(*) FROM $quoted");

    my $rows = $dbh->selectall_arrayref("SELECT * FROM $quoted LIMIT ?", { Slice => {} }, $limit) || [];

    return {

        database => $opt{db},

        table => $table,

        generated_at => iso_now(),

        limit => $limit,

        row_count => int($row_count || 0),

        columns => $columns,

        indexes => \@index_details,

        foreign_keys => $foreign_keys,

        rows => $rows,

    };

}

    my ($table) = @_;

    my $dbh = dbh();

    $table = clean_scalar($table);

    return { error => 'missing_table' } unless length $table;

    return { error => 'invalid_table' } unless debug_table_exists($dbh, $table);

    my $quoted = $dbh->quote_identifier($table);

    my $columns = $dbh->selectall_arrayref("PRAGMA table_info($quoted)", { Slice => {} }) || [];

    my @column_names = map { $_->{name} || '' } @$columns;

    my ($row_count) = $dbh->selectrow_array("SELECT COUNT(*) FROM $quoted");

    my $rows = $dbh->selectall_arrayref("SELECT * FROM $quoted", { Slice => {} }) || [];

    return {

        database => $opt{db},

        table => $table,

        generated_at => iso_now(),

        row_count => int($row_count || 0),

        columns => \@column_names,

        rows => $rows,

    };

}

sub render_debug_table_csv {

    my ($export) = @_;

    my @columns = @{ $export->{columns} || [] };

    my @lines = (join(',', map { csv_cell($_) } @columns));

    for my $row (@{ $export->{rows} || [] }) {

        push @lines, join(',', map { csv_cell($row->{$_}) } @columns);

    }

    return join("\n", @lines) . "\n";

}

sub csv_cell {

    my ($value) = @_;

    $value = '' unless defined $value;

    $value = "$value";

    $value =~ s/"/""/g;

    return qq("$value") if $value =~ /[",\r\n]/;

    return $value;

}

sub debug_table_export_filename {

    my ($table, $extension) = @_;

    $table = clean_scalar($table || 'table');

    $table =~ s/[^A-Za-z0-9_.-]+/-/g;

    $table = 'table' unless length $table;

    return "debug-$table.$extension";

}

    my ($dbh, $table) = @_;

    return 0 unless $table =~ /\A[A-Za-z_][A-Za-z0-9_]*\z/;

    my ($exists) = $dbh->selectrow_array(

        "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = ? AND name NOT LIKE 'sqlite_%'",

        undef,

        $table,

    );

    return $exists ? 1 : 0;

}

sub sum {

    my $total = 0;

    $total += $_ || 0 for @_;

    return $total;

}

    return "$project_dir/scripts/ca_manager.sh";

}

sub ca_dir {

    return $ENV{HOST_MANAGER_CA_DIR} || "$project_dir/var/ca";

}

sub ca_cert_path {

    return ca_dir() . "/certs/ca.cert.pem";

}

    my ($name) = @_;

    die "unsafe certificate name\n" unless $name =~ /\A[A-Za-z0-9_.-]+\z/;

    return ca_dir() . "/issued/$name.cert.pem";

}

    my ($name) = @_;

    die "unsafe certificate name\n" unless $name =~ /\A[A-Za-z0-9_.-]+\z/;

    return ca_dir() . "/issued/$name.key.pem";

}

sub ca_manager_output {

    my (@args) = @_;

    die "CA manager script is missing\n" unless -x $script;

    local $ENV{HOST_MANAGER_CA_DIR} = ca_dir();

    my $out = <$fh>;

    close $fh or die "CA manager failed\n";

}

sub ca_manager_json {

    my ($command) = @_;

    my $out = ca_manager_output($command);

    sync_certificates_from_json($out) if $command eq 'list-json';

    return $out;

}

sub sync_certificates_from_json {

    my ($json) = @_;

    my $certs = eval { json_decode($json || '[]') };

    return if $@ || ref($certs) ne 'ARRAY';

    my $dbh = dbh();

    my $now = iso_now();

    with_transaction($dbh, sub {

        for my $cert (@$certs) {

            next unless ref($cert) eq 'HASH';

            my $name = clean_id($cert->{name} || $cert->{serial} || $cert->{fingerprint_sha256} || '');

            next unless $name;

            my @dns_names = map { normalize_dns_name($_) } @{ $cert->{dns_names} || [] };

            my $host_fqdn = infer_certificate_host_fqdn($dbh, \@dns_names);

            my $cert_path = ca_issued_cert_path($name);

            my $csr_path = ca_dir() . "/csr/$name.csr.pem";

            my $serial = clean_scalar($cert->{serial} || '');

            my $fingerprint = clean_scalar($cert->{fingerprint_sha256} || '');

            $dbh->do(

                'INSERT INTO certificates (certificate_id, host_fqdn, common_name, subject, issuer, serial, status, not_before, not_after, fingerprint_sha256, cert_path, csr_path, created_at, updated_at, notes) '

                . "VALUES (?, ?, ?, ?, ?, ?, 'issued', ?, ?, ?, ?, ?, ?, ?, '') "

                . 'ON CONFLICT(certificate_id) DO UPDATE SET host_fqdn = excluded.host_fqdn, common_name = excluded.common_name, '

                . 'subject = excluded.subject, issuer = excluded.issuer, serial = excluded.serial, status = excluded.status, '

                . 'not_before = excluded.not_before, not_after = excluded.not_after, fingerprint_sha256 = excluded.fingerprint_sha256, '

                . 'cert_path = excluded.cert_path, csr_path = excluded.csr_path, updated_at = excluded.updated_at',

                undef,

                $name,

                $host_fqdn || undef,

                $dns_names[0] || '',

                clean_scalar($cert->{subject} || ''),

                clean_scalar($cert->{issuer} || ''),

                length($serial) ? $serial : undef,

                clean_scalar($cert->{not_before} || ''),

                clean_scalar($cert->{not_after} || ''),

                length($fingerprint) ? $fingerprint : undef,

                $cert_path,

                $csr_path,

                $now,

                $now,

            );

            $dbh->do('DELETE FROM certificate_dns_names WHERE certificate_id = ?', undef, $name);

            for my $dns_name (@dns_names) {

                next unless length $dns_name;

                $dbh->do(

                    'INSERT OR IGNORE INTO certificate_dns_names (certificate_id, dns_name) VALUES (?, ?)',

                    undef,

                    $name,

                    $dns_name,

                );

            }

        }

    });

}

sub infer_certificate_host_fqdn {

    my ($dbh, $dns_names) = @_;

    for my $name (@$dns_names) {

        my ($fqdn) = $dbh->selectrow_array('SELECT fqdn FROM hosts WHERE fqdn = ?', undef, $name);

        return $fqdn if $fqdn;

    }

    for my $name (@$dns_names) {

        my ($fqdn) = $dbh->selectrow_array('SELECT host_fqdn FROM host_aliases WHERE alias_name = ? AND status = ?', undef, $name, 'active');

        return $fqdn if $fqdn;

        ($fqdn) = $dbh->selectrow_array('SELECT host_fqdn FROM vhosts WHERE vhost_fqdn = ? AND status = ?', undef, $name, 'active');

        return $fqdn if $fqdn;

    }

    return '';

    my ($text) = @_;

    my %registry = (

        version => 1,

        updated_at => '',

        policy => {},

        hosts => [],

    );

    my ($section, $current, $list_key);

    for my $line (split /\n/, $text) {

        next if $line =~ /^\s*$/ || $line =~ /^\s*#/;

        if ($line =~ /^version:\s*(\d+)/) {

            $registry{version} = int($1);

        } elsif ($line =~ /^updated_at:\s*(.+)$/) {

            $registry{updated_at} = yaml_unquote($1);

        } elsif ($line =~ /^policy:\s*$/) {

            $section = 'policy';

        } elsif ($line =~ /^hosts:\s*$/) {

            $section = 'hosts';

        } elsif (($section || '') eq 'policy' && $line =~ /^  ([A-Za-z0-9_]+):\s*(.+)$/) {

            $registry{policy}{$1} = yaml_unquote($2);

        } elsif (($section || '') eq 'hosts' && $line =~ /^  - id:\s*(.+)$/) {

            $current = {

                id => yaml_unquote($1),

                aliases => [],

                vhosts => [],

                sources => [],

                monitoring => 'pending',

                notes => '',

            };

            push @{ $registry{hosts} }, $current;

            $list_key = undef;

        } elsif ($current && $line =~ /^    ([A-Za-z0-9_]+):\s*$/) {

            $list_key = $1;

            $current->{$list_key} ||= [];

        } elsif ($current && defined $list_key && $line =~ /^      -\s*(.+)$/) {

            push @{ $current->{$list_key} }, yaml_unquote($1);

        } elsif ($current && $line =~ /^    ([A-Za-z0-9_]+):\s*(.*)$/) {