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

        $print_local_hosts_tsv = 1;

        usage();

        exit 0;

    } else {

        die "Unknown option: $arg\n";

    }

}

    print render_local_hosts_tsv(load_registry());

    exit 0;

}

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.

                                  Defaults to var/dns-publish.trigger.

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 collect_dhcp_leases($client, \%headers, $body);

    }

    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 set_host_certificate($client, $payload);

        }

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

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

            return issue_host_certificate($client, $payload);

        }

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

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

    }

    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,

        },

    };

}

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

    my $expected = $ENV{HOST_MANAGER_DHCP_PUSH_TOKEN} || '';

    return send_json($client, 503, { error => 'dhcp_push_not_configured' }) unless length $expected;

    my $provided = dhcp_push_token_from_headers($headers);

    return send_json($client, 401, { error => 'invalid_dhcp_push_token' }) unless token_matches($expected, $provided);

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

    my @leases = dhcp_payload_leases($payload);

    return send_json($client, 400, { error => 'missing_dhcp_leases' }) unless @leases;

    my $dbh = dbh();

    my $now = iso_now();

    my $worker_id = clean_id($payload->{worker_id} || $payload->{source_id} || 'dhcp-router');

    $worker_id ||= 'dhcp-router';

    my @stored;

    with_transaction($dbh, sub {

        upsert_dhcp_worker($dbh, $worker_id, $now);

        for my $lease (@leases) {

            my $stored = upsert_dhcp_lease($dbh, $worker_id, $lease, $now);

            push @stored, $stored if $stored;

        }

        $dbh->do(

            'UPDATE data_workers SET last_run_at = ?, updated_at = ? WHERE worker_id = ?',

            undef,

            $now,

            $now,

            $worker_id,

        );

    });

    return send_json($client, 200, {

        ok => json_bool(1),

        worker_id => $worker_id,

        stored => scalar(@stored),

        leases => \@stored,

    });

}

sub dhcp_push_token_from_headers {

    my ($headers) = @_;

    my $token = clean_scalar($headers->{'x-dhcp-push-token'} || '');

    return $token if length $token;

    my $authorization = clean_scalar($headers->{authorization} || '');

    return $1 if $authorization =~ /\ABearer\s+(.+)\z/i;

    return '';

}

sub token_matches {

    my ($expected, $provided) = @_;

    return 0 unless length($expected || '') && length($provided || '');

    return 0 unless length($expected) == length($provided);

    my $diff = 0;

    for my $i (0 .. length($expected) - 1) {

        $diff |= ord(substr($expected, $i, 1)) ^ ord(substr($provided, $i, 1));

    }

    return $diff == 0 ? 1 : 0;

}

sub dhcp_payload_leases {

    my ($payload) = @_;

    return () unless ref($payload) eq 'HASH';

    if (ref($payload->{leases}) eq 'ARRAY') {

        return grep { ref($_) eq 'HASH' } @{ $payload->{leases} };

    }

    return ($payload);

}

sub upsert_dhcp_worker {

    my ($dbh, $worker_id, $now) = @_;

    $dbh->do(

        'INSERT INTO data_workers (worker_id, worker_type, name, status, source, last_run_at, notes, created_at, updated_at) '

        . "VALUES (?, 'dhcp', 'Router DHCP leases', 'active', 'push:192.168.2.1', ?, 'DHCP lease push collector source.', ?, ?) "

        . 'ON CONFLICT(worker_id) DO UPDATE SET worker_type = excluded.worker_type, name = excluded.name, status = excluded.status, '

        . 'source = excluded.source, last_run_at = excluded.last_run_at, notes = excluded.notes, updated_at = excluded.updated_at',

        undef,

        $worker_id,

        $now,

        $now,

        $now,

    );

}

sub upsert_dhcp_lease {

    my ($dbh, $worker_id, $lease, $now) = @_;

    my $ip = clean_ip($lease->{ip_address} || $lease->{ip} || $lease->{address} || '');

    my $mac = clean_mac($lease->{mac_address} || $lease->{mac} || $lease->{active_mac} || '');

    return unless length $ip || length $mac;

    my $name = normalize_dhcp_name($lease->{observed_name} || $lease->{host_name} || $lease->{hostname} || $lease->{name} || '');

    my $state = clean_scalar($lease->{lease_state} || $lease->{state} || $lease->{status} || '');

    if (!length $state && exists $lease->{bound}) {

        $state = ($lease->{bound} || '') eq '1' ? 'bound' : 'unbound';

    }

    $state ||= 'observed';

    my $lease_key = length $mac ? "$worker_id|mac|$mac" : "$worker_id|ip|$ip";

    my $host_fqdn = match_dhcp_host_fqdn($dbh, $name, $ip);

    my $raw = json_encode($lease);

    $dbh->do(

        'INSERT INTO dhcp_leases (lease_key, worker_id, host_fqdn, observed_name, ip_address, mac_address, lease_state, first_seen, last_seen, raw) '

        . 'VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?) '

        . 'ON CONFLICT(lease_key) DO UPDATE SET host_fqdn = excluded.host_fqdn, observed_name = excluded.observed_name, '

        . 'ip_address = excluded.ip_address, mac_address = excluded.mac_address, lease_state = excluded.lease_state, '

        . 'last_seen = excluded.last_seen, raw = excluded.raw',

        undef,

        $lease_key,

        $worker_id,

        length($host_fqdn) ? $host_fqdn : undef,

        $name,

        $ip,

        $mac,

        $state,

        $now,

        $now,

        $raw,

    );

    return {

        lease_key => $lease_key,

        host_fqdn => $host_fqdn,

        observed_name => $name,

        ip_address => $ip,

        mac_address => $mac,

        lease_state => $state,

    };

}

sub match_dhcp_host_fqdn {

    my ($dbh, $name, $ip) = @_;

    my @names;

    $name = normalize_dns_name($name || '');

    if (length $name) {

        push @names, $name;

        push @names, "$name.madagascar.xdev.ro" unless $name =~ /\./;

    }

    for my $candidate (unique_preserve(@names)) {

        my ($fqdn) = $dbh->selectrow_array('SELECT fqdn FROM hosts WHERE fqdn = ? AND status <> ?', undef, $candidate, 'retired');

        return $fqdn if $fqdn;

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

        return $fqdn if $fqdn;

    }

    if (length($ip || '')) {

        my ($fqdn) = $dbh->selectrow_array('SELECT fqdn FROM hosts WHERE (dns_ip = ? OR hosts_ip = ?) AND status <> ? ORDER BY fqdn LIMIT 1', undef, $ip, $ip, 'retired');

        return $fqdn if $fqdn;

    }

    return '';

}

    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';

    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 @hosts = map { host_payload($_, $host_tls{ canonical_host_fqdn($_) }) } @{ $registry->{hosts} };

    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

    ht.host_fqdn,

    ht.certificate_id,

    c.common_name,

    c.not_after,

    c.fingerprint_sha256,

    c.status AS certificate_status

FROM host_tls ht

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

ORDER BY ht.host_fqdn

SQL

    $sth->execute;

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

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

        next unless length $host_fqdn;

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

        my %payload = (

            certificate_id => $cert_id,

        );

        if (length $cert_id) {

            $payload{certificate} = {

                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(ca_private_key_exists($cert_id)),

            };

        }

        $rows{$host_fqdn} = \%payload;

    }

    return %rows;

}

    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.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} || ''),

        push @rows, {

            vhost => $row->{vhost_fqdn},

            vhost_fqdn => $row->{vhost_fqdn},

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

            host_fqdn => $row->{host_fqdn},

            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) ],

    }

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

    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, dns_publish => $publish });

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

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

    my $target_fqdn = normalize_dns_name($payload->{host_fqdn} || $payload->{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');

        "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 || '', dns_publish => $publish });

sub delete_vhost {

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

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

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

    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, dns_publish => $publish });

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

    my $host_fqdn = normalize_dns_name($payload->{host_fqdn} || $payload->{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_host' }) unless $host_fqdn;

    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 => 'host_not_found' })

        unless db_scalar($dbh, "SELECT COUNT(*) FROM hosts WHERE fqdn = ? AND status = 'active'", $host_fqdn);

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

    with_transaction($dbh, sub {

        upsert_host_tls_row($dbh, $host_fqdn, $certificate_id, $now);

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

    });

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

}

sub issue_host_certificate {

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

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

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

    my $registry = load_registry();

    my ($host) = grep { canonical_host_fqdn($_) eq $host_fqdn } @{ $registry->{hosts} || [] };

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

    my @dns_names = unique_preserve(grep { length $_ } (

        $host_fqdn,

        declared_alias_names($host),

        derived_alias_names($host),

    ));

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

    my $dbh = dbh();

    my $issued = eval {

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

        ca_manager_json('list-json');

        with_transaction($dbh, sub {

            my $now = iso_now();

            upsert_host_tls_row($dbh, $host_fqdn, $certificate_id, $now);

            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),

        host_fqdn => $host_fqdn,

        certificate_id => $certificate_id,

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

    });

}

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

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

    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;

}

    $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) ];

    $copy{certificate} = $tls->{certificate} if $tls && ref($tls->{certificate}) eq 'HASH';

}

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), derived_alias_names($host);

    return unique_preserve(@names);

}

sub vhost_cname_records {

    my ($host) = @_;

    my $target = canonical_host_fqdn($host);

    return () unless length $target;

    my @records;

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

        push @records, [ $vhost, $target ];

        if (my $short = short_alias_for_fqdn($vhost)) {

            push @records, [ $short, $target ];

        }

    }

    my %seen;

    return grep { !$seen{$_->[0]}++ } @records;

}

    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";