#!/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");

    }

    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 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});

        version => $registry->{version},

        updated_at => $registry->{updated_at},

        policy => $registry->{policy},

        counts => {

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

        },

    };

}

sub upsert_host {

    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 ($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 ($command) = @_;

    my $script = ca_script_path();

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

    local $ENV{HOST_MANAGER_CA_DIR} = ca_dir();

    open my $fh, '-|', $script, $command or die "Cannot run CA manager\n";

    local $/;

    my $out = <$fh>;

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

    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*(.*)$/) {

            my $value = yaml_unquote($2);

            if ($key eq 'ip') {

                $current->{ip} = $value;

            } elsif ($key eq 'dns_ip' || $key eq 'hosts_ip') {

                $current->{ip} ||= $value;

            } elsif ($key eq 'fqdn') {

                $current->{fqdn} = normalize_dns_name($value);

            } elsif ($key eq 'names') {

                # ignored here; legacy list is handled after parsing

            } else {

                $current->{$key} = $value;

            }

        }

    }

        my @legacy_names = @{ $host->{names} || [] };

        if (@legacy_names) {

            my $legacy = split_legacy_names($host->{id}, \@legacy_names);

            $host->{fqdn} ||= $legacy->{fqdn};

            $host->{aliases} = $legacy->{aliases} unless @{ $host->{aliases} || [] };

            $host->{vhosts} = $legacy->{vhosts} unless @{ $host->{vhosts} || [] };

        }

        delete $host->{names};

        $host->{fqdn} ||= canonical_host_fqdn($host);

    }

}

sub render_hosts_yaml {

    my ($registry) = @_;

    my $out = "version: " . int($registry->{version} || 1) . "\n";

    $out .= "updated_at: " . yq($registry->{updated_at} || iso_now()) . "\n";

    $out .= "policy:\n";

    for my $key (sort keys %{ $registry->{policy} || {} }) {

        $out .= "  $key: " . yq($registry->{policy}{$key}) . "\n";

    }

    $out .= "hosts:\n";

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

        $out .= "  - id: " . yq($host->{id}) . "\n";

        $out .= "    status: " . yq($host->{status} || '') . "\n";

        $out .= "    ip: " . yq(canonical_ip($host)) . "\n";

        for my $key (qw(aliases vhosts roles sources)) {

            for my $value (@{ $host->{$key} || [] }) {

                $out .= "      - " . yq($value) . "\n";

            }

        }

        $out .= "    monitoring: " . yq($host->{monitoring} || 'pending') . "\n";

        $out .= "    notes: " . yq($host->{notes} || '') . "\n";

    }

    return $out;

}

    my ($text) = @_;

    my %orders = (

        version => 1,

        work_orders => [],

    );

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

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

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

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

            $section = 'work_orders';

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

            $current = {

                id => yaml_unquote($1),

                status => 'pending',

            };

            push @{ $orders{work_orders} }, $current;

        } elsif ($current && $line =~ /^    checklist:\s*$/) {

            $list_section = 'checklist';

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

        } elsif ($current && $list_section eq 'checklist' && $line =~ /^      - id:\s*(.+)$/) {

            $current_item = { id => yaml_unquote($1), status => 'pending' };

            push @{ $current->{checklist} }, $current_item;

            $current_action = undef;

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

            $current_item->{$1} = yaml_unquote($2);

            push @{ $current->{actions} }, $current_action;

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

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

            $current->{$1} = yaml_unquote($2);

    }

    return \%orders;

}

sub render_work_orders_yaml {

    my ($orders) = @_;

    my $out = "version: " . int($orders->{version} || 1) . "\n";

    $out .= "work_orders:\n";

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

        $out .= "  - id: " . yq($wo->{id}) . "\n";

        for my $key (qw(status title reason created_at confirmed_at result)) {

            next unless exists $wo->{$key} && length($wo->{$key} || '');

            $out .= "    $key: " . yq($wo->{$key}) . "\n";

        }

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

            $out .= "      - id: " . yq($item->{id}) . "\n";

            for my $key (qw(text status owner notes updated_at)) {

                next unless exists $item->{$key} && length($item->{$key} || '');

                $out .= "        $key: " . yq($item->{$key}) . "\n";

            }

        }

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

            $out .= "      - type: " . yq($action->{type}) . "\n";

            for my $key (qw(host_id name)) {

                next unless exists $action->{$key} && length($action->{$key} || '');

                $out .= "        $key: " . yq($action->{$key}) . "\n";

            }

        }

    }

    return $out;

}

    my ($headers, $body) = @_;

    my $type = $headers->{'content-type'} || '';

    if ($type =~ m{application/json}) {

        return json_decode($body || '{}');

    }

    return { parse_params($body || '') };

}

sub json_bool {

    my ($value) = @_;

    return bless \(my $bool = $value ? 1 : 0), 'HostManager::JSONBool';

}

sub json_encode {

    my ($value) = @_;

    if (!defined $value) {

        return 'null';

    }

    my $ref = ref($value);

    if (!$ref) {

        return $value if $value =~ /\A-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?\z/;

        return json_string($value);

    }

    if ($ref eq 'HostManager::JSONBool') {

        return $$value ? 'true' : 'false';

    }

    if ($ref eq 'ARRAY') {