#!/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 Digest::SHA qw(hmac_sha1 hmac_sha256_hex sha256_hex); 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, data => $ENV{HOST_MANAGER_DATA} || "$project_dir/config/hosts.yaml", local_hosts_tsv => $ENV{HOST_MANAGER_LOCAL_HOSTS_TSV} || "$project_dir/config/local-hosts.tsv", work_orders => $ENV{HOST_MANAGER_WORK_ORDERS} || "$project_dir/config/work-orders.yaml", ); while (@ARGV) { my $arg = shift @ARGV; if ($arg eq '--bind') { $opt{bind} = shift @ARGV; } elsif ($arg eq '--port') { $opt{port} = shift @ARGV; } elsif ($arg eq '--data') { $opt{data} = shift @ARGV; } elsif ($arg eq '--local-hosts-tsv') { $opt{local_hosts_tsv} = shift @ARGV; } elsif ($arg eq '--work-orders') { $opt{work_orders} = shift @ARGV; } elsif ($arg eq '--help' || $arg eq '-h') { 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 "data file: $opt{data}\n"; print "OTP login: " . ($ENV{HOST_MANAGER_TOTP_SECRET} ? "enabled\n" : "disabled; set HOST_MANAGER_TOTP_SECRET\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_DATA Defaults to config/hosts.yaml. HOST_MANAGER_LOCAL_HOSTS_TSV Defaults to config/local-hosts.tsv. HOST_MANAGER_WORK_ORDERS Defaults to config/work-orders.yaml. The nginx vhost keeps registry, CA, work order and download endpoints behind OTP. EOF } 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 '/') { return send_html($client, 200, app_html()); } if ($method eq 'GET' && $path eq '/healthz') { return send_json($client, 200, { ok => json_bool(1) }); } if ($method eq 'GET' && $path eq '/api/session') { return send_json($client, 200, { authenticated => is_authenticated(\%headers) ? json_bool(1) : json_bool(0) }); } if ($method eq 'POST' && $path eq '/api/login') { 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); if ($method eq 'GET' && $path eq '/api/hosts') { my $registry = load_registry(); return send_json($client, 200, registry_payload($registry)); } if ($method eq 'GET' && $path eq '/api/work-orders') { return send_json($client, 200, work_orders_payload(load_work_orders())); } if ($method eq 'GET' && $path eq '/download/hosts.yaml') { return send_file($client, $opt{data}, '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'); } if ($method eq 'GET' && $path eq '/api/ca/status') { 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'); } 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} || ''); } if ($path eq '/api/work-orders/confirm') { my $payload = request_payload(\%headers, $body); return confirm_work_order($client, $payload); } if ($path eq '/api/work-orders/checklist') { my $payload = request_payload(\%headers, $body); return update_work_order_checklist($client, $payload); } if ($path eq '/api/render/local-hosts-tsv') { 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' }); } sub load_registry { return parse_hosts_yaml(read_file($opt{data})); } sub save_registry { my ($registry) = @_; $registry->{updated_at} = iso_now(); backup_file($opt{data}); write_file($opt{data}, render_hosts_yaml($registry)); } sub load_work_orders { return { version => 1, work_orders => [] } unless -f $opt{work_orders}; return parse_work_orders_yaml(read_file($opt{work_orders})); } sub save_work_orders { my ($orders) = @_; backup_file($opt{work_orders}); write_file($opt{work_orders}, render_work_orders_yaml($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'; my $incomplete = incomplete_work_order_items($work_order); 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}, }); } sub update_work_order_checklist { 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; } sub apply_work_order { 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; } sub registry_payload { my ($registry) = @_; my $problems = analyze_hosts($registry->{hosts}); my @hosts = map { host_payload($_) } @{ $registry->{hosts} }; return { version => $registry->{version}, updated_at => $registry->{updated_at}, policy => $registry->{policy}, hosts => \@hosts, problems => $problems, 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 @names = remove_derived_names(clean_list($payload->{names})); return send_json($client, 400, { error => 'missing_names' }) unless @names; 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}++; } my %declared = map { $_ => 1 } @{ $host->{names} || [] }; for my $derived (derived_names($host)) { push @problems, problem($host, 'redundant-derived-name', "Name $derived is derived from madagascar.xdev.ro") if $declared{$derived}; } if (($host->{hosts_ip} || '') ne ($host->{dns_ip} || '') && ($host->{hosts_ip} || '') ne '127.0.0.1') { push @problems, problem($host, 'split-ip', 'hosts_ip differs from dns_ip; check that this is intentional'); } } return \@problems; } sub host_payload { 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; } sub problem { 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 .= "# Generated by scripts/host_manager.pl from config/hosts.yaml.\n"; $out .= "#\n"; $out .= "# Format:\n"; $out .= "# hosts_ipdns_ipname [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'; my @names = effective_names($host); 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'; my @names = effective_names($host); push @hosts, { id => $host->{id}, primary_name => $names[0], address => $host->{dns_ip}, aliases => \@names, declared_names => [ @{ $host->{names} || [] } ], derived_names => [ derived_names($host) ], roles => [ @{ $host->{roles} || [] } ], monitoring => $host->{monitoring} || 'pending', notes => $host->{notes} || '', }; } return { version => $registry->{version}, generated_at => iso_now(), source => 'config/hosts.yaml', hosts => \@hosts, }; } sub ca_script_path { 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"; } sub ca_manager_json { 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"; return $out || '{}'; } sub parse_hosts_yaml { 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; } sub parse_work_orders_yaml { my ($text) = @_; my %orders = ( version => 1, work_orders => [], ); my ($section, $current, $list_section, $current_action, $current_item); for my $line (split /\n/, $text) { 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', checklist => [], actions => [], }; push @{ $orders{work_orders} }, $current; $list_section = ''; $current_action = undef; $current_item = undef; } 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); } elsif ($current && $line =~ /^ actions:\s*$/) { $list_section = 'actions'; $current->{actions} ||= []; } elsif ($current && $list_section eq 'actions' && $line =~ /^ - type:\s*(.+)$/) { $current_action = { type => yaml_unquote($1) }; push @{ $current->{actions} }, $current_action; $current_item = undef; } elsif ($current_action && $list_section eq 'actions' && $line =~ /^ ([A-Za-z0-9_]+):\s*(.*)$/) { $current_action->{$1} = yaml_unquote($2); } elsif ($current && $line =~ /^ ([A-Za-z0-9_]+):\s*(.*)$/) { $current->{$1} = yaml_unquote($2); $list_section = ''; $current_action = undef; $current_item = undef; } } 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"; } $out .= " checklist:\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"; } } $out .= " actions:\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; } sub request_payload { 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); } sub send_json_raw { my ($client, $status, $json_body, $extra_headers) = @_; return send_response($client, $status, $json_body, 'application/json; charset=utf-8', $extra_headers); } sub send_html { 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) = @_; my %reason = (200 => 'OK', 400 => 'Bad Request', 401 => 'Unauthorized', 404 => 'Not Found', 409 => 'Conflict', 500 => 'Internal Server Error', 503 => 'Service Unavailable'); $body = '' unless defined $body; 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 url_decode { my ($value) = @_; $value = '' unless defined $value; $value =~ tr/+/ /; $value =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; return $value; } sub random_hex { my ($bytes) = @_; if (open my $fh, '<:raw', '/dev/urandom') { read($fh, my $raw, $bytes); close $fh; return unpack('H*', $raw); } return sha256_hex(rand() . time() . $$); } sub iso_now { return strftime('%Y-%m-%dT%H:%M:%SZ', gmtime); } sub build_info { my %info = ( revision => '', branch => '', built_at => '', deployed_at => '', dirty => '', ); if ($ENV{HOST_MANAGER_BUILD}) { $info{revision} = clean_scalar($ENV{HOST_MANAGER_BUILD}); return \%info; } my $build_file = "$project_dir/BUILD"; if (-f $build_file) { for my $line (split /\n/, read_file($build_file)) { next unless $line =~ /\A([A-Za-z0-9_.-]+)=(.*)\z/; $info{$1} = clean_scalar($2); } return \%info if $info{revision} || $info{built_at}; } my $revision = git_value('rev-parse --short=12 HEAD'); my $branch = git_value('rev-parse --abbrev-ref HEAD'); $info{revision} = $revision if $revision; $info{branch} = $branch if $branch && $branch ne 'HEAD'; return \%info; } sub git_value { my ($args) = @_; return '' unless -d "$project_dir/.git"; open my $fh, '-|', "git -C '$project_dir' $args 2>/dev/null" or return ''; my $value = <$fh> || ''; close $fh; chomp $value; return clean_scalar($value); } sub build_label { my $info = build_info(); my $revision = $info->{revision} || 'unknown'; my $branch = $info->{branch} || ''; $branch = '' if $branch eq 'HEAD'; my $label = $branch ? "$branch $revision" : $revision; $label .= '+dirty' if ($info->{dirty} || '') eq '1'; return $label; } sub build_title { my $info = build_info(); my $label = build_label(); my $stamp = $info->{deployed_at} || $info->{built_at} || ''; return $stamp ? "$label deployed $stamp" : $label; } sub html_escape { my ($value) = @_; $value = '' unless defined $value; $value =~ s/&/&/g; $value =~ s//>/g; $value =~ s/"/"/g; $value =~ s/'/'/g; return $value; } sub app_html { my $build = html_escape(build_label()); my $build_title = html_escape(build_title()); my $html = <<'HTML'; Madagascar Local Authority

Madagascar Local Authority

hosts.yaml local-hosts.tsv monitoring.json

Overview

Local Certificate Authority

ca.crt

Work Orders

Hosts

ID hosts_ip dns_ip Names Roles Monitoring Status

Edit host

build __HOST_MANAGER_BUILD__
HTML $html =~ s/__HOST_MANAGER_BUILD_TITLE__/$build_title/g; $html =~ s/__HOST_MANAGER_BUILD__/$build/g; return $html; }