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

    }

        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 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 = grep { $_ ne $name } @{ $host->{names} || [] };

                $removed = @kept != @{ $host->{names} || [] };

                $host->{names} = \@kept;

                last;

            }

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

            problems => scalar @$problems,

        },

    };

}

sub upsert_host {

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

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

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

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

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

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

    my $registry = load_registry();

    my %host = (

        id => $id,

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

        hosts_ip => $hosts_ip,

        dns_ip => $dns_ip,

        names => \@names,

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

        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;

        }

    }

    push @{ $registry->{hosts} }, \%host unless $replaced;

    save_registry($registry);

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

}

sub analyze_hosts {

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

        my @fqdn = grep { /\.madagascar\.xdev\.ro$/ } @{ $host->{names} || [] };

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

        push @problems, problem($host, 'deprecated-vad-is', 'Deprecated vad.is.xdev.ro name present')

            if grep { /\.vad\.is\.xdev\.ro$/ } @{ $host->{names} || [] };

        push @problems, problem($host, 'legacy-prefix', 'Legacy prefix should be normalized out')

            if grep { /^(is|vad|b)-/ } @{ $host->{names} || [] };

        for my $name (@{ $host->{names} || [] }) {

            push @problems, problem($host, 'duplicate-name', "Duplicate name $name") if $names{$name}++;

        }

        for my $derived (derived_names($host)) {

            push @problems, problem($host, 'redundant-derived-name', "Name $derived is derived from madagascar.xdev.ro")

                if $declared{$derived};

        }

            push @problems, problem($host, 'split-ip', 'hosts_ip differs from dns_ip; check that this is intentional');

        }

    }

    return \@problems;

}

    my ($host) = @_;

    my %copy = %$host;

    $copy{names} = [ effective_names($host) ];

    $copy{declared_names} = [ @{ $host->{names} || [] } ];

    $copy{derived_names} = [ derived_names($host) ];

    return \%copy;

}

sub effective_names {

    my ($host) = @_;

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

    push @names, derived_names($host);

    return unique_preserve(@names);

}

sub derived_names {

    my ($host) = @_;

    my @derived;

    for my $name (@{ $host->{names} || [] }) {

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

        push @derived, $1 if length $1;

    }

    return unique_preserve(@derived);

}

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, $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 .= "# hosts_ip<TAB>dns_ip<TAB>name [aliases...]\n";

    $out .= "#\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 @names;

        $out .= join("\t", $host->{hosts_ip}, $host->{dns_ip}, join(' ', @names)) . "\n";

    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 => [ @{ $host->{names} || [] } ],

            derived_names => [ derived_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,

    };

}

sub debug_table_exists {

    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;

    }

    for my $name (@$dns_names) {

        return $name if $name =~ /\./;

    }

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

                status => 'active',

                hosts_ip => '',

                dns_ip => '',

                names => [],

                roles => [],

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

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

            $list_key = undef;

        }

    }

    return \%registry;

}

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

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

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

        }

        for my $key (qw(names roles sources)) {

            $out .= "    $key:\n";

            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') {

        return '[' . join(',', map { json_encode($_) } @$value) . ']';

    }

    if ($ref eq 'HASH') {

        return '{' . join(',', map { json_string($_) . ':' . json_encode($value->{$_}) } sort keys %$value) . '}';

    }

    return json_string("$value");

}

sub json_string {

    my ($value) = @_;

    $value = '' unless defined $value;

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

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

    $value =~ s/\n/\\n/g;

    $value =~ s/\r/\\r/g;

    $value =~ s/\t/\\t/g;

    $value =~ s/([\x00-\x1f])/sprintf("\\u%04x", ord($1))/eg;

    return qq("$value");

}

sub json_decode {

    my ($text) = @_;

    my $i = 0;

    my $len = length($text);

    my ($parse_value, $parse_string, $parse_array, $parse_object, $parse_number, $skip_ws);

    $skip_ws = sub {

        $i++ while $i < $len && substr($text, $i, 1) =~ /\s/;

    };

    $parse_string = sub {

        die "Expected JSON string\n" unless substr($text, $i, 1) eq '"';

        $i++;

        my $out = '';

        while ($i < $len) {

            my $ch = substr($text, $i++, 1);

            return $out if $ch eq '"';

            if ($ch eq "\\") {

                die "Bad JSON escape\n" if $i >= $len;

                my $esc = substr($text, $i++, 1);

                if ($esc eq '"' || $esc eq "\\" || $esc eq '/') {

                    $out .= $esc;

                } elsif ($esc eq 'b') {

                    $out .= "\b";

                } elsif ($esc eq 'f') {

                    $out .= "\f";

                } elsif ($esc eq 'n') {

                    $out .= "\n";

                } elsif ($esc eq 'r') {

                    $out .= "\r";

                } elsif ($esc eq 't') {

                    $out .= "\t";

                } elsif ($esc eq 'u') {

                    my $hex = substr($text, $i, 4);

                    die "Bad JSON unicode escape\n" unless $hex =~ /\A[0-9A-Fa-f]{4}\z/;

                    $out .= chr(hex($hex));

                    $i += 4;

                } else {

                    die "Bad JSON escape\n";

                }

            } else {

                $out .= $ch;

            }

        }

        die "Unterminated JSON string\n";

    };

    $parse_number = sub {

        my $start = $i;

        $i++ if substr($text, $i, 1) eq '-';

        $i++ while $i < $len && substr($text, $i, 1) =~ /[0-9]/;

        if ($i < $len && substr($text, $i, 1) eq '.') {

            $i++;

            $i++ while $i < $len && substr($text, $i, 1) =~ /[0-9]/;

        }

        if ($i < $len && substr($text, $i, 1) =~ /[eE]/) {

            $i++;

            $i++ if $i < $len && substr($text, $i, 1) =~ /[+-]/;

            $i++ while $i < $len && substr($text, $i, 1) =~ /[0-9]/;

        }

        return 0 + substr($text, $start, $i - $start);

    };

    $parse_array = sub {

        die "Expected JSON array\n" unless substr($text, $i, 1) eq '[';

        $i++;

        my @out;

        $skip_ws->();

        if ($i < $len && substr($text, $i, 1) eq ']') {

            $i++;

            return \@out;

        }

        while (1) {

            push @out, $parse_value->();

            $skip_ws->();

            my $ch = substr($text, $i++, 1);

            last if $ch eq ']';

            die "Expected JSON array comma\n" unless $ch eq ',';

        }

        return \@out;

    };

    $parse_object = sub {

        die "Expected JSON object\n" unless substr($text, $i, 1) eq '{';

        $i++;

        my %out;

        $skip_ws->();

        if ($i < $len && substr($text, $i, 1) eq '}') {

            $i++;

            return \%out;

        }

        while (1) {

            $skip_ws->();

            my $key = $parse_string->();

            $skip_ws->();

            die "Expected JSON object colon\n" unless substr($text, $i++, 1) eq ':';

            $out{$key} = $parse_value->();

            $skip_ws->();

            my $ch = substr($text, $i++, 1);

            last if $ch eq '}';

            die "Expected JSON object comma\n" unless $ch eq ',';

        }

        return \%out;

    };

    $parse_value = sub {

        $skip_ws->();

        die "Unexpected end of JSON\n" if $i >= $len;

        my $ch = substr($text, $i, 1);

        return $parse_string->() if $ch eq '"';

        return $parse_object->() if $ch eq '{';

        return $parse_array->() if $ch eq '[';

        if (substr($text, $i, 4) eq 'true') {

            $i += 4;

            return json_bool(1);

        }

        if (substr($text, $i, 5) eq 'false') {

            $i += 5;

            return json_bool(0);

        }

        if (substr($text, $i, 4) eq 'null') {

            $i += 4;

            return undef;

        }

        return $parse_number->() if $ch =~ /[-0-9]/;

        die "Unexpected JSON token\n";

    };

    my $value = $parse_value->();

    $skip_ws->();

    die "Trailing JSON content\n" if $i != $len;

    return $value;

}

sub parse_params {

    my ($text) = @_;

    my %out;

    for my $pair (split /&/, $text) {

        next unless length $pair;

        my ($k, $v) = split /=/, $pair, 2;

        $out{url_decode($k)} = url_decode($v || '');

    }

    return %out;

}

sub clean_id {

    my ($value) = @_;

    $value = lc clean_scalar($value);

    $value =~ s/[^a-z0-9_.-]+/-/g;

    $value =~ s/^-+|-+$//g;

    return $value;

}

sub clean_scalar {

    my ($value) = @_;

    $value = '' unless defined $value;

    $value =~ s/[\r\n\t]+/ /g;

    $value =~ s/^\s+|\s+$//g;

    return $value;

}

sub clean_list {

    my ($value) = @_;

    return () unless defined $value;

    my @items = ref($value) eq 'ARRAY' ? @$value : split /[\s,]+/, $value;

    my @clean;

    for my $item (@items) {

        $item = clean_scalar($item);

        push @clean, $item if length $item;

    }

    return @clean;

}

sub yq {

    my ($value) = @_;

    $value = '' unless defined $value;

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

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

    return qq("$value");

}

sub yaml_unquote {

    my ($value) = @_;

    $value = '' unless defined $value;

    $value =~ s/^\s+|\s+$//g;

    if ($value =~ /^"(.*)"$/) {

        $value = $1;

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

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

    }

    return $value;

}

sub verify_totp {

    my ($secret, $otp) = @_;

    return 0 unless $secret && $otp =~ /^\d{6}$/;

    my $key = eval { base32_decode($secret) };

    return 0 if $@ || !length $key;

    my $counter = int(time() / 30);

    for my $offset (-1, 0, 1) {

        return 1 if totp_code($key, $counter + $offset) eq $otp;

    }

    return 0;

}

sub totp_code {

    my ($key, $counter) = @_;

    my $msg = pack('NN', int($counter / 4294967296), $counter & 0xffffffff);

    my $hash = hmac_sha1($msg, $key);

    my $offset = ord(substr($hash, -1)) & 0x0f;

    my $bin = unpack('N', substr($hash, $offset, 4)) & 0x7fffffff;

    return sprintf('%06d', $bin % 1_000_000);

}

sub base32_decode {

    my ($text) = @_;

    $text = uc($text || '');

    $text =~ s/[^A-Z2-7]//g;

    my %map;

    my @chars = ('A'..'Z', '2'..'7');

    @map{@chars} = (0..31);

    my ($bits, $value, $out) = (0, 0, '');

    for my $char (split //, $text) {

        die "Invalid base32\n" unless exists $map{$char};

        $value = ($value << 5) | $map{$char};

        $bits += 5;

        while ($bits >= 8) {

            $bits -= 8;

            $out .= chr(($value >> $bits) & 0xff);

        }

    }

    return $out;

}

sub create_session {

    my $nonce = random_hex(24);

    my $expires = int(time() + 8 * 3600);

    my $sig = hmac_sha256_hex("$nonce:$expires", $session_secret);

    my $token = "$nonce:$expires:$sig";

    $sessions{$token} = $expires;

    return $token;

}

sub is_authenticated {

    my ($headers) = @_;

    my $token = cookie_value($headers->{'cookie'} || '', 'hm_session');

    return 0 unless $token;

    my ($nonce, $expires, $sig) = split /:/, $token;

    return 0 unless $nonce && $expires && $sig;

    return 0 if $expires < time();

    return 0 unless hmac_sha256_hex("$nonce:$expires", $session_secret) eq $sig;

    return exists $sessions{$token};

}

sub expire_session {

    my ($headers) = @_;

    my $token = cookie_value($headers->{'cookie'} || '', 'hm_session');

    delete $sessions{$token} if $token;

}

sub cookie_value {

    my ($cookie, $name) = @_;

    for my $part (split /;\s*/, $cookie) {

        my ($k, $v) = split /=/, $part, 2;

        return $v if defined $k && $k eq $name;

    }

    return '';

}

sub send_json {

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

    return send_response($client, $status, json_encode($payload), 'application/json; charset=utf-8', $extra_headers);

}

    my ($client, $status, $json_body, $extra_headers) = @_;

    return send_response($client, $status, $json_body, 'application/json; charset=utf-8', $extra_headers);

}

    my ($client, $status, $html) = @_;

    return send_response($client, $status, $html, 'text/html; charset=utf-8');

}

sub send_text {

    my ($client, $status, $text) = @_;

    return send_response($client, $status, $text, 'text/plain; charset=utf-8');

}

sub send_download {

    my ($client, $status, $content, $type, $filename) = @_;

    return send_response($client, $status, $content, $type, [ qq(Content-Disposition: attachment; filename="$filename") ]);

}

sub send_file {

    my ($client, $path, $type, $filename) = @_;

    return send_json($client, 404, { error => 'missing_file' }) unless -f $path;

    return send_download($client, 200, read_file($path), $type, $filename);

}

sub send_response {

    my ($client, $status, $body, $type, $extra_headers) = @_;

    print $client "HTTP/1.1 $status " . ($reason{$status} || 'OK') . "\r\n";

    print $client "Content-Type: $type\r\n";

    print $client "Content-Length: " . length($body) . "\r\n";

    print $client "Cache-Control: no-store\r\n";

    print $client "$_\r\n" for @{ $extra_headers || [] };

    print $client "Connection: close\r\n\r\n";

    print $client $body;

}

sub read_file {

    my ($path) = @_;

    open my $fh, '<', $path or die "Cannot read $path: $!";

    local $/;

    return <$fh>;

}

sub write_file {

    my ($path, $content) = @_;

    open my $fh, '>', $path or die "Cannot write $path: $!";

    print {$fh} $content;

    close $fh or die "Cannot close $path: $!";

}

sub backup_file {

    my ($path) = @_;

    return unless -f $path;

    my $backup_dir = "$project_dir/backups/host-manager";

    make_path($backup_dir) unless -d $backup_dir;

    my $name = $path;

    $name =~ s{.*/}{};

    my $stamp = strftime('%Y%m%d_%H%M%S', localtime);

    write_file("$backup_dir/$name.$stamp.bak", read_file($path));

}

sub dbh {

    return $db_handle if $db_handle;

    ensure_parent_dir($opt{db});

    $db_handle = DBI->connect(

        "dbi:SQLite:dbname=$opt{db}",

        '',

        '',

        {

            RaiseError => 1,

            PrintError => 0,

            AutoCommit => 1,

            sqlite_unicode => 1,

        },

    ) or die "Cannot open SQLite database $opt{db}\n";

    $db_handle->do('PRAGMA journal_mode = WAL');

    $db_handle->do('PRAGMA foreign_keys = ON');

    seed_database($db_handle) unless $db_seeded++;

    return $db_handle;

}

sub create_database_schema {

    my ($dbh) = @_;

    $dbh->do(<<'SQL');

CREATE TABLE IF NOT EXISTS schema_meta (

    key TEXT PRIMARY KEY,

    value TEXT NOT NULL,

    updated_at TEXT NOT NULL

)

SQL

    $dbh->do(<<'SQL');

    name TEXT PRIMARY KEY,

    content TEXT NOT NULL,

    updated_at TEXT NOT NULL

)

SQL

        'INSERT INTO schema_meta (key, value, updated_at) VALUES (?, ?, ?) '

        . 'ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at',

        undef, 'schema_version', '2', iso_now()

    );

    $dbh->do(<<'SQL');

CREATE TABLE IF NOT EXISTS hosts (

    fqdn TEXT PRIMARY KEY,

    legacy_id TEXT NOT NULL UNIQUE,

    status TEXT NOT NULL DEFAULT 'active',

    hosts_ip TEXT NOT NULL DEFAULT '',

    dns_ip TEXT NOT NULL DEFAULT '',

    monitoring TEXT NOT NULL DEFAULT 'pending',

    notes TEXT NOT NULL DEFAULT '',

    created_at TEXT NOT NULL,

    updated_at TEXT NOT NULL

)

SQL

    $dbh->do(<<'SQL');

CREATE TABLE IF NOT EXISTS host_aliases (

    alias_name TEXT NOT NULL,

    host_fqdn TEXT NOT NULL,

    alias_kind TEXT NOT NULL DEFAULT 'declared',

    status TEXT NOT NULL DEFAULT 'active',

    is_dns_published INTEGER NOT NULL DEFAULT 1,

    created_at TEXT NOT NULL,

    retired_at TEXT,

    notes TEXT NOT NULL DEFAULT '',

    PRIMARY KEY (alias_name, host_fqdn),

    FOREIGN KEY (host_fqdn) REFERENCES hosts(fqdn) ON UPDATE CASCADE ON DELETE RESTRICT

)

SQL

    $dbh->do(<<'SQL');

CREATE UNIQUE INDEX IF NOT EXISTS idx_host_aliases_active_name

ON host_aliases(alias_name)

WHERE status = 'active'