← Back
Editing: kea-dhcp-lib.pl
# kea-dhcp-lib.pl # Helpers for the ISC Kea DHCP Webmin module. BEGIN { push(@INC, ".."); }; ## no critic use strict; use warnings; use WebminCore; our (%config, %in, %text); our $module_root_directory; &init_config(); &load_kea_defaults(); # kea_can_view_dhcp(&acl, version) # Structured edit access implies read access to that DHCP version. sub kea_can_view_dhcp { my ($acl, $ver) = @_; return $acl->{'dhcp'.$ver} || $acl->{'edit'.$ver} ? 1 : 0; } # kea_can_edit_dhcp(&acl, version) # Returns true if the user may change structured DHCPv4 or DHCPv6 settings. sub kea_can_edit_dhcp { my ($acl, $ver) = @_; return $acl->{'edit'.$ver} ? 1 : 0; } # kea_can_view_ddns(&acl) # DHCP-DDNS edit access implies read access to the D2 daemon settings. sub kea_can_view_ddns { my ($acl) = @_; return $acl->{'ddns'} || $acl->{'editddns'} ? 1 : 0; } # kea_can_edit_ddns(&acl) # Returns true if the user may change structured DHCP-DDNS settings. sub kea_can_edit_ddns { my ($acl) = @_; return $acl->{'editddns'} ? 1 : 0; } # kea_can_view_services(&acl) # Service control implies enough service visibility to choose the right action. sub kea_can_view_services { my ($acl) = @_; return $acl->{'services'} || $acl->{'apply'} ? 1 : 0; } # kea_can_view_runtime(&acl) # Returns true if the user may view lease, pool, statistics, and log data. sub kea_can_view_runtime { my ($acl) = @_; return $acl->{'runtime'} ? 1 : 0; } # load_kea_defaults() # When a new module is copied into an existing Webmin install, its runtime # config file may not exist yet even though config.cgi can still display # defaults from config.info. Fill missing runtime values from the module's # bundled config so the module works before the first Save on the config page. sub load_kea_defaults { my %defaults; &read_file($module_root_directory."/config", \%defaults) if ($module_root_directory && -r $module_root_directory."/config"); foreach my $k (keys %defaults) { if (!defined($config{$k}) || $config{$k} eq '') { $config{$k} = $defaults{$k}; } } } # kea_config_value(key) # Returns a module configuration value after defaults have been loaded. sub kea_config_value { my ($key) = @_; return $config{$key}; } # kea_components() # Returns descriptors for the Kea services this module knows how to inspect. sub kea_components { return ( { 'id' => 'dhcp4', 'root' => 'Dhcp4', 'conf' => 'dhcp4_conf', 'path' => 'dhcp4_path', 'pid' => 'dhcp4_pid_file', 'proc' => 'kea-dhcp4', 'unit' => &kea_config_value('dhcp4_unit'), 'label' => $text{'comp_dhcp4'} || 'DHCPv4' }, { 'id' => 'dhcp6', 'root' => 'Dhcp6', 'conf' => 'dhcp6_conf', 'path' => 'dhcp6_path', 'pid' => 'dhcp6_pid_file', 'proc' => 'kea-dhcp6', 'unit' => &kea_config_value('dhcp6_unit'), 'label' => $text{'comp_dhcp6'} || 'DHCPv6' }, { 'id' => 'ddns', 'root' => 'DhcpDdns', 'conf' => 'ddns_conf', 'path' => 'ddns_path', 'pid' => 'ddns_pid_file', 'proc' => 'kea-dhcp-ddns', 'unit' => &kea_config_value('ddns_unit'), 'label' => $text{'comp_ddns'} || 'DHCP-DDNS' }, { 'id' => 'ctrl', 'root' => 'Control-agent', 'conf' => 'ctrl_agent_conf', 'path' => 'ctrl_agent_path', 'pid' => 'ctrl_agent_pid_file', 'proc' => 'kea-ctrl-agent', 'unit' => &kea_config_value('ctrl_agent_unit'), 'label' => $text{'comp_ctrl'} || 'Control Agent' }, ); } # kea_component(id) # Looks up one Kea component descriptor by its internal module id. sub kea_component { my ($id) = @_; foreach my $c (&kea_components()) { return $c if ($c->{'id'} eq $id); } return; } # kea_dhcp_component(version) # Returns the DHCPv4 or DHCPv6 component descriptor for a numeric version. sub kea_dhcp_component { my ($ver) = @_; return &kea_component($ver == 6 ? 'dhcp6' : 'dhcp4'); } # kea_component_systemd_unit(&component) # Returns the configured systemd unit for this component. Distro-specific unit # names belong in config-* defaults rather than guessed at runtime. sub kea_component_systemd_unit { my ($c) = @_; return $c->{'unit'} || ""; } # kea_subnet_key(version) # Returns the Kea JSON subnet array key for DHCPv4 or DHCPv6. sub kea_subnet_key { my ($ver) = @_; return $ver == 6 ? 'subnet6' : 'subnet4'; } # kea_config_file(&component) # Returns the configured JSON file path for a component descriptor. sub kea_config_file { my ($c) = @_; return &kea_config_value($c->{'conf'}); } # kea_editable_components() # Returns components that have a configured file path for manual editing. sub kea_editable_components { my @rv; foreach my $c (&kea_components()) { push(@rv, $c) if (&kea_config_file($c)); } return @rv; } # kea_control_agent_password_files() # Returns password files referenced by the Kea Control Agent authentication # section, plus the packaged default derived from the Control Agent config dir. sub kea_control_agent_password_files { my @rv; my $c = &kea_component('ctrl'); my $file = &kea_config_file($c); return @rv if (!$file); # Debian-style packages gate the Control Agent with this file even when the # config only refers to it by a relative name. my $dir = &kea_dirname($file); my $default = "$dir/kea-api-password"; $default = &simplify_path($default) if ($default =~ /^\//); push(@rv, $default); if (-r $file) { my ($root, $err) = &kea_read_component_config($c); if (!$err && ref($root->{'authentication'}) eq 'HASH') { my $auth = $root->{'authentication'}; my $base = $auth->{'directory'} || $dir; my $clients = $auth->{'clients'}; if (ref($clients) eq 'ARRAY') { foreach my $client (@$clients) { next if (ref($client) ne 'HASH'); my $pfile = $client->{'password-file'}; next if (!defined($pfile) || $pfile eq ''); # Kea resolves relative password-file values below # authentication/directory. my $path = $pfile =~ /^\// ? $pfile : "$base/$pfile"; $path = &simplify_path($path) if ($path =~ /^\//); push(@rv, $path) if ($path); } } } } return grep { $_ } &unique(@rv); } # kea_manual_edit_files() # Returns descriptors for files the raw editor may manage. sub kea_manual_edit_files { my (@rv, %seen); # Manual editing is deliberately limited to configured Kea files. This prevents # the raw editor from becoming a general-purpose filesystem editor. foreach my $c (&kea_editable_components()) { my $file = &kea_config_file($c); next if (!$file || $seen{$file}++); push(@rv, { 'file' => $file, 'type' => 'config', 'component' => $c }); } # Include Control Agent password files because a missing password can make the # unit look inactive without any broken JSON to edit. foreach my $file (&kea_control_agent_password_files()) { next if (!$file || $seen{$file}++); push(@rv, { 'file' => $file, 'type' => 'password' }); } return @rv; } # kea_manual_edit_file(file) # Returns the manual-edit descriptor for an allowed file path. sub kea_manual_edit_file { my ($file) = @_; foreach my $f (&kea_manual_edit_files()) { return $f if ($f->{'file'} eq $file); } return; } # kea_any_installed() # Returns true when at least one configured Kea executable exists. sub kea_any_installed { return 1 if (&has_command(&kea_config_value('keactrl_path'))); foreach my $c (&kea_components()) { return 1 if (&has_command(&kea_config_value($c->{'path'}))); } return 0; } # kea_any_configured() # Returns true when at least one configured Kea config file is readable. sub kea_any_configured { foreach my $c (&kea_components()) { my $file = &kea_config_file($c); return 1 if ($file && -r $file); } return 0; } # kea_component_pid(&component) # Finds the running process ID for a Kea component. sub kea_component_pid { my ($c) = @_; # Prefer distro PID files when configured, then fall back to process lookup for # systems that run Kea without the expected pidfile names. foreach my $pidfile (split(/\s+/, &kea_config_value($c->{'pid'}) || "")) { my $pid = &check_pid_file($pidfile); return $pid if ($pid); } my ($pid) = &find_byname($c->{'proc'}); return $pid; } # kea_component_status(&component) # Returns normalized runtime status for a Kea component. sub kea_component_status { my ($c) = @_; our %kea_component_status_cache; return $kea_component_status_cache{$c->{'id'}} if (exists($kea_component_status_cache{$c->{'id'}})); my $pid = &kea_component_pid($c); my $status = { 'state' => $pid ? 'running' : 'stopped', 'pid' => $pid, 'manager' => 'process', 'details' => [ ], 'logs' => [ ], }; # systemd is the source of truth for failed/skipped services; PID checks alone # cannot distinguish a clean stop from a failed start or unmet condition. my $systemctl = &has_command('systemctl'); my $unit = &kea_component_systemd_unit($c); if ($systemctl && $unit) { my $props = &kea_systemd_unit_properties($unit); if (%$props) { $status->{'manager'} = 'systemd'; $status->{'unit'} = $unit; $status->{'active'} = $props->{'ActiveState'}; $status->{'sub'} = $props->{'SubState'}; $status->{'result'} = $props->{'Result'}; $status->{'condition_result'} = $props->{'ConditionResult'}; $status->{'unit_file_state'} = $props->{'UnitFileState'}; if ($props->{'MainPID'} =~ /^\d+$/ && $props->{'MainPID'} > 0) { $status->{'pid'} = $props->{'MainPID'}; } if ($props->{'LoadState'} && $props->{'LoadState'} eq 'not-found') { $status->{'state'} = $status->{'pid'} ? 'running' : 'unknown'; push(@{$status->{'details'}}, $text{'status_unit_missing'}); } elsif ($props->{'ActiveState'} eq 'active') { $status->{'state'} = 'running'; } elsif ($props->{'ActiveState'} eq 'failed') { $status->{'state'} = 'failed'; } elsif ($props->{'ActiveState'} eq 'activating') { $status->{'state'} = 'starting'; } elsif ($props->{'ActiveState'} eq 'deactivating') { $status->{'state'} = 'stopping'; } elsif ($props->{'Result'} eq 'condition' || defined($props->{'ConditionResult'}) && $props->{'ConditionResult'} eq 'no') { $status->{'state'} = 'skipped'; } elsif ($props->{'ActiveState'} eq 'inactive') { $status->{'state'} = 'stopped'; } else { $status->{'state'} = $status->{'pid'} ? 'running' : 'unknown'; } # Only attach detailed logs to abnormal states so the services # table stays compact when everything is healthy. if ($status->{'state'} eq 'failed' || $status->{'state'} eq 'skipped') { push(@{$status->{'details'}}, &text('status_result', $props->{'Result'})) if ($props->{'Result'} && $props->{'Result'} ne 'success'); push(@{$status->{'details'}}, $text{'status_condition_unmet'}) if ($status->{'state'} eq 'skipped'); push(@{$status->{'details'}}, &text('status_exit', $props->{'ExecMainStatus'})) if ($props->{'ExecMainStatus'} =~ /^\d+$/ && $props->{'ExecMainStatus'} != 0); $status->{'logs'} = &kea_systemd_unit_logs( $unit, $status->{'state'}); } } } return $kea_component_status_cache{$c->{'id'}} = $status; } # kea_systemd_unit_properties(unit) # Reads selected systemd properties for a configured unit. sub kea_systemd_unit_properties { my ($unit) = @_; my $systemctl = &has_command('systemctl'); return { } if (!$systemctl); # Query explicit properties instead of parsing localized systemctl status text. my $cmd = "e_path($systemctl). " show --no-pager --property=LoadState,ActiveState,SubState,". "Result,MainPID,ExecMainStatus,ExecMainCode,UnitFileState,". "ConditionResult ". quotemeta($unit)." 2>/dev/null"; my $out = &backquote_command($cmd); return { } if ($? || $out !~ /\S/); my %props; foreach my $line (split(/\r?\n/, $out)) { my ($name, $value) = split(/=/, $line, 2); $props{$name} = $value if ($name ne ''); } return \%props; } # kea_systemd_unit_logs(unit, state) # Returns recent systemd journal lines relevant to a component state. sub kea_systemd_unit_logs { my ($unit, $state) = @_; my $journalctl = &has_command('journalctl'); return [ ] if (!$journalctl); if ($state eq 'skipped') { # Skipped units usually need the unmet condition rather than ordinary # warnings. my @condition = &kea_recent_unique_lines(grep { /\b(condition|skipped|unmet)\b/i } &kea_journal_lines($journalctl, $unit, "", 12)); return [ @condition > 3 ? @condition[$#condition-2 .. $#condition] : @condition ] if (@condition); } if ($state eq 'failed') { # Kea emits the real config/parser error in its daemon log line; prefer # that over generic systemd process-exit messages. my @errors = &kea_recent_unique_lines(grep { &kea_is_relevant_error_line($_) } &kea_journal_lines($journalctl, $unit, "", 20)); return [ @errors > 3 ? @errors[$#errors-2 .. $#errors] : @errors ] if (@errors); } # For non-failure states, keep the newest useful log lines as optional context. my @logs = &kea_recent_unique_lines(grep { !&kea_is_low_value_unit_line($_) } &kea_journal_lines($journalctl, $unit, "--priority warning")); @logs = &kea_recent_unique_lines(&kea_journal_lines($journalctl, $unit, "")) if (!@logs); return [ @logs > 3 ? @logs[$#logs-2 .. $#logs] : @logs ]; } # kea_is_relevant_error_line(line) # Returns true for journal lines likely to contain actionable Kea errors. sub kea_is_relevant_error_line { my ($line) = @_; return 0 if (&kea_is_low_value_unit_line($line)); return $line =~ /\b(ERROR|_FAIL|failed to initialize|configuration error|parser|unexpected keyword|invalid)\b/i; } # kea_is_low_value_unit_line(line) # Filters generic systemd noise from service diagnostics. sub kea_is_low_value_unit_line { my ($line) = @_; return $line =~ /ConfigurationDirectory .* mode is different/i || $line =~ /Main process exited/i || $line =~ /Failed with result/i; } # kea_recent_unique_lines(lines...) # Keeps the newest copy of repeated journal messages. sub kea_recent_unique_lines { my @lines = @_; my (%seen, @rv); for(my $i=$#lines; $i>=0; $i--) { my $key = $lines[$i]; # De-duplicate retries of the same failure while preserving the newest # text. $key =~ s/\d{4}-\d\d-\d\d\s+\d\d:\d\d:\d\d(?:\.\d+)?/<time>/g; $key =~ s/\bpid:\s*\d+/pid:<pid>/ig; $key =~ s#/(\d+)\.#/<pid>.#g; next if ($seen{$key}++); unshift(@rv, $lines[$i]); } return @rv; } # kea_journal_lines(journalctl, unit, extra-args, [lines]) # Reads normalized recent journal lines for one systemd unit. sub kea_journal_lines { my ($journalctl, $unit, $extra, $lines) = @_; $lines ||= 6; my $cmd = "e_path($journalctl)." --unit ".quotemeta($unit). " --lines ".int($lines)." --no-pager --output cat ". ($extra ? $extra." " : "")."2>/dev/null"; my $out = &backquote_command($cmd); return ( ) if ($?); my @lines; foreach my $line (split(/\r?\n/, $out)) { $line =~ s/^\s+|\s+$//g; next if ($line eq ''); push(@lines, &kea_short_text($line, 180)); } return @lines; } # kea_short_text(text, max-length) # Truncates long service messages for compact table display. sub kea_short_text { my ($text, $max) = @_; $max ||= 180; return length($text) > $max ? substr($text, 0, $max - 3)."..." : $text; } # kea_running_pids() # Returns process IDs for Kea components currently considered running. sub kea_running_pids { my @rv; foreach my $c (&kea_components()) { my $status = &kea_component_status($c); push(@rv, $status->{'pid'} || 1) if ($status->{'state'} eq 'running'); } return @rv; } # kea_parse_config_file(file) # Reads and parses a Kea config file into a Perl data structure. sub kea_parse_config_file { my ($file) = @_; my $text = &read_file_contents($file); die &text('file_eread', $file) if (!defined($text)); return &kea_parse_config_text($text, $file); } # kea_parse_config_text(text, file) # Parses Kea JSON text after expanding include directives. sub kea_parse_config_text { my ($text, $file) = @_; my $dir = &kea_dirname($file); # Kea supports <?include "..."> fragments; expand them before handing the # result to Webmin's relaxed JSON reader. $text = &kea_expand_includes($text, $dir, 0); my $data = eval { &convert_from_json($text, undef, 1) }; die &text('parse_ejson', $@) if ($@); return $data; } # kea_encode_config(&data) # Serializes a Kea config object as stable, pretty JSON for structured saves. sub kea_encode_config { my ($data) = @_; # Structured edits intentionally save clean, pretty JSON. Comments from distro # sample configs are not preserved after the first structured save. return &convert_to_json($data, 1); } # kea_config_has_comments(file) # Detects comment syntax that will be removed by structured JSON saves. sub kea_config_has_comments { my ($file) = @_; return 0 if (!$file || !-r $file); my $text = &read_file_contents($file); return 0 if (!defined($text)); # Kea package examples commonly use whole-line JSONC comments. Detecting those # is enough to warn before a structured save normalizes the file to plain JSON. return $text =~ m{^\s*(?://|#|/\*)}m ? 1 : 0; } # kea_comment_loss_warning(&component, ...) # Builds the warning shown before saving comment-bearing config files. sub kea_comment_loss_warning { my @components = @_; my @files; foreach my $c (@components) { next if (!$c); my $file = &kea_config_file($c); push(@files, $file) if (&kea_config_has_comments($file)); } return "" if (!@files); # Name the exact config file so users know which Kea daemon will be rewritten # when a settings page is saved. my $list = join(", ", map { &ui_tag('tt', &html_escape($_)) } @files); my $msg = @files == 1 ? &text('comments_loss_warning', $list) : &text('comments_loss_warning_multi', $list); return &ui_alert_box($msg, "success", undef, undef, ""); } # kea_expand_includes(text, base-dir, depth) # Expands Kea <?include "..."> directives recursively. sub kea_expand_includes { my ($text, $base, $depth) = @_; die $text{'include_edepth'} if ($depth > 10); # The substitution calls back into kea_include_file so nested includes inherit # their own base directory. $text =~ s/<\?include\s+"([^"]+)"\s*\?>/&kea_include_file($1, $base, $depth)/ge; return $text; } # kea_include_file(path, base-dir, depth) # Reads and expands one Kea include target. sub kea_include_file { my ($inc, $base, $depth) = @_; my $file = $inc =~ /^\// ? $inc : -r "$base/$inc" ? "$base/$inc" : $inc; my $text = &read_file_contents($file); die &text('include_eread', $file) if (!defined($text)); $text = &kea_expand_includes($text, &kea_dirname($file), $depth + 1); # Kea commonly includes a JSON object inside another object and merges its # members. Stripping the outer braces lets normal JSON parsers read that shape. my $trim = $text; $trim =~ s/^\s+//; $trim =~ s/\s+$//; if ($trim =~ /^\{(.*)\}$/s) { return $1; } return $text; } # kea_dirname(file) # Returns the containing directory for a path. sub kea_dirname { my ($file) = @_; $file =~ s/\/[^\/]*$//; return $file || "."; } # kea_read_component_config(&component) # Reads one component config and returns its root object. sub kea_read_component_config { my ($c) = @_; my $file = &kea_config_file($c); return (undef, &text('config_missing', '')) if (!$file); return (undef, &text('config_missing', $file)) if (!-e $file); return (undef, &text('config_unreadable', $file)) if (!-r $file); my $data = eval { &kea_parse_config_file($file) }; return (undef, $@) if ($@); if (ref($data->{$c->{'root'}}) ne 'HASH') { return (undef, &text('parse_eroot', $c->{'root'})); } return ($data->{$c->{'root'}}, undef, $data); } # kea_read_dhcp_config(version) # Reads the DHCPv4 or DHCPv6 component config. sub kea_read_dhcp_config { my ($ver) = @_; my $c = &kea_dhcp_component($ver); my ($root, $err, $data) = &kea_read_component_config($c); return ($c, $root, $data, $err); } # kea_save_component_config(&component, &data) # Validates and writes a component config file. sub kea_save_component_config { my ($c, $data) = @_; my $file = &kea_config_file($c); return $text{'save_efile'} if (!$file); my $json = eval { &kea_encode_config($data) }; return $@ if ($@); my $verr = &kea_validate_component_json($c, $json); return $verr if ($verr); # Use Webmin's lock/tempfile path so concurrent UI edits and backups see a # normal module-managed config write. &lock_file($file); my $fh; &open_tempfile($fh, ">$file"); &print_tempfile($fh, $json); &close_tempfile($fh); &unlock_file($file); return; } # kea_validate_component_json(&component, json) # Runs Kea's native config test before replacing a live daemon file. Test # fixtures often point component paths at perl itself, so only execute real Kea # binaries whose basename matches the component descriptor. sub kea_validate_component_json { my ($c, $json) = @_; my $cmd = &kea_config_value($c->{'path'}); return if (!$cmd || !-x $cmd); my $base = $cmd; $base =~ s/^.*\///; return if ($base ne $c->{'proc'}); # Debian's Kea AppArmor profile permits reading /etc/kea/** but denies # Webmin's normal /tmp/.webmin candidates. Validate from the same directory as # the live config so Kea sees the file through its packaged security policy. my $file = &kea_config_file($c); my $dir = &kea_dirname($file); my $tmp = $dir."/".$c->{'proc'}."-test-". &substitute_pattern('[a-f0-9]{6}').".conf"; push(@main::temporary_files, $tmp); my $fh; if (!&open_tempfile($fh, ">$tmp", 1)) { return &text('save_etemp', $tmp, $!); } &print_tempfile($fh, $json); if (!&close_tempfile($fh)) { return &text('save_etemp', $tmp, $!); } my @st = $file ? stat($file) : ( ); my $mode = @st ? $st[2] & 07777 : 0644; if (!chmod($mode, $tmp)) { my $cerr = $!; &unlink_file($tmp); return &text('save_etemp', $tmp, $cerr); } if (@st && $> == 0 && !chown($st[4], $st[5], $tmp)) { my $cerr = $!; &unlink_file($tmp); return &text('save_etemp', $tmp, $cerr); } my ($out, $err); my $rv = &execute_command(quotemeta($cmd)." -t ".quotemeta($tmp), undef, \$out, \$err, 0, 1); &unlink_file($tmp); return if (!$rv); my $msg = $err || $out || &text('save_evalidate_empty'); $msg =~ s/\r//g; $msg =~ s/^\s+//; $msg =~ s/\s+$//; return &text('save_evalidate', $c->{'label'}, $msg); } # kea_shared_networks(&root) # Returns the shared-networks array, creating an empty one if needed. sub kea_shared_networks { my ($root) = @_; # Normalize missing shared-networks to an array so callers can safely mutate it. $root->{'shared-networks'} = [ ] if (ref($root->{'shared-networks'}) ne 'ARRAY'); return $root->{'shared-networks'}; } # kea_subnet_list(&root, version, [shared-index]) # Returns top-level or shared-network subnet arrays. sub kea_subnet_list { my ($root, $ver, $sidx) = @_; my $key = &kea_subnet_key($ver); my $parent = $sidx ne '' ? &kea_shared_networks($root)->[$sidx] : $root; return [ ] if (ref($parent) ne 'HASH'); # Top-level and shared-network subnets use the same key, only with different # parents. $parent->{$key} = [ ] if (ref($parent->{$key}) ne 'ARRAY'); return $parent->{$key}; } # kea_valid_subnet_parent(&root, [shared-index]) # Returns true when a subnet parent index is top-level or an existing shared network. sub kea_valid_subnet_parent { my ($root, $sidx) = @_; return 1 if (!defined($sidx) || $sidx eq ''); return 0 if ($sidx !~ /^\d+$/); # Reject negative and out-of-range parent indexes before Perl can treat them as # reverse array indexes. return ref(&kea_shared_networks($root)->[$sidx]) eq 'HASH'; } # kea_get_subnet(&root, version, [shared-index], subnet-index) # Returns one subnet object from its stored location. sub kea_get_subnet { my ($root, $ver, $sidx, $idx) = @_; return &kea_subnet_list($root, $ver, $sidx)->[$idx]; } # kea_all_subnets(&root, version) # Returns every subnet with location metadata for editing and deletion. sub kea_all_subnets { my ($root, $ver) = @_; my @rv; # Return both top-level subnets and subnets nested below shared networks with # enough location metadata for edit/delete links. my $top = &kea_subnet_list($root, $ver, ""); for(my $i=0; $i<@$top; $i++) { push(@rv, { 'sidx' => '', 'idx' => $i, 'subnet' => $top->[$i] }); } my $shareds = &kea_shared_networks($root); for(my $s=0; $s<@$shareds; $s++) { my $subs = &kea_subnet_list($root, $ver, $s); for(my $i=0; $i<@$subs; $i++) { push(@rv, { 'sidx' => $s, 'idx' => $i, 'shared' => $shareds->[$s], 'subnet' => $subs->[$i] }); } } return @rv; } # kea_next_subnet_id(&root, version) # Finds the next unused numeric subnet id. sub kea_next_subnet_id { my ($root, $ver) = @_; my $max = 0; foreach my $s (&kea_all_subnets($root, $ver)) { my $id = $s->{'subnet'}->{'id'}; $max = $id if ($id =~ /^\d+$/ && $id > $max); } return $max + 1; } # kea_lease_file(version, [&root]) # Resolves the memfile lease CSV path for a DHCP version. sub kea_lease_file { my ($ver, $root) = @_; if (!$root) { my (undef, $read_root, undef, $err) = &kea_read_dhcp_config($ver); return ("", $err) if ($err); $root = $read_root; } my $db = ref($root->{'lease-database'}) eq 'HASH' ? $root->{'lease-database'} : { }; my $type = lc($db->{'type'} || 'memfile'); return ("", &text('leases_backend_unsupported', $type)) if ($type ne 'memfile'); my $default = &kea_config_value('dhcp'.$ver.'_lease_file') || ""; my $name = $db->{'name'} || ""; return ($name, undef) if ($name =~ /^\//); return (&kea_dirname($default)."/".$name, undef) if ($name && $default =~ /^\//); return ($default, undef); } # kea_read_leases(version) # Reads Kea memfile CSV leases and returns parsed rows, error text, and path. sub kea_read_leases { my ($ver) = @_; my (undef, $root, undef, $err) = &kea_read_dhcp_config($ver); return ([ ], $err, "") if ($err); my ($file, $ferr) = &kea_lease_file($ver, $root); return ([ ], $ferr, $file) if ($ferr); return ([ ], $text{'leases_enofile'}, $file) if (!$file); return ([ ], &text('leases_missing', $file), $file) if (!-e $file); return ([ ], &text('leases_unreadable', $file), $file) if (!-r $file); my $text = &read_file_contents($file); my @lines = split(/\r?\n/, $text); my @heads; my @leases; foreach my $line (@lines) { $line =~ s/^\s+|\s+$//g; next if ($line eq '' || $line =~ /^#/); my @cols = &kea_csv_fields($line); if (!@heads) { @heads = map { &kea_normalize_lease_field($_) } @cols; next; } my %lease; for(my $i=0; $i<@heads; $i++) { $lease{$heads[$i]} = defined($cols[$i]) ? $cols[$i] : ""; } push(@leases, \%lease); } return (\@leases, undef, $file); } # kea_csv_fields(line) # Parses one Kea memfile CSV row using Perl's standard quoted-field parser. sub kea_csv_fields { my ($line) = @_; eval { require Text::ParseWords; }; return split(/,/, $line, -1) if ($@); my @cols = Text::ParseWords::parse_line(',', 0, $line); return @cols; } # kea_normalize_lease_field(field) # Converts CSV header names to hash keys that are easy to read in the UI. sub kea_normalize_lease_field { my ($field) = @_; $field = lc($field || ""); $field =~ s/^\s+|\s+$//g; $field =~ s/[-\s]+/_/g; return $field; } # kea_active_leases(version) # Returns active leases for a DHCP version, preserving file/error context. sub kea_active_leases { my ($ver) = @_; my ($leases, $err, $file) = &kea_read_leases($ver); return ([ grep { &kea_lease_is_active($_) } @$leases ], $err, $file); } # kea_lease_is_active(&lease) # Returns true for leases Kea still considers usable by clients. sub kea_lease_is_active { my ($lease) = @_; my $state = $lease->{'state'}; return 0 if (defined($state) && $state ne '' && $state ne '0'); my $expire = $lease->{'expire'}; return 1 if (!defined($expire) || $expire eq '' || $expire !~ /^\d+$/); return $expire == 0 || $expire > time() ? 1 : 0; } # kea_lease_address(&lease) # Returns the address or delegated prefix shown for one lease. sub kea_lease_address { my ($lease) = @_; return $lease->{'address'} || $lease->{'ip_address'} || $lease->{'prefix'} || ""; } # kea_lease_identifier(&lease) # Returns the most useful client identity from one DHCP lease row. sub kea_lease_identifier { my ($lease) = @_; return $lease->{'hwaddr'} || $lease->{'hw_address'} || $lease->{'client_id'} || $lease->{'duid'} || $lease->{'iaid'} || ""; } # kea_lease_expires(&lease) # Returns human-readable lease expiration text. sub kea_lease_expires { my ($lease) = @_; my $expire = $lease->{'expire'}; return $text{'leases_never'} if (defined($expire) && $expire eq '0'); return "" if (!defined($expire) || $expire eq '' || $expire !~ /^\d+$/); return scalar(localtime($expire)); } # kea_lease_state(&lease) # Returns a compact state label for a lease CSV row. sub kea_lease_state { my ($lease) = @_; my $state = $lease->{'state'}; return $text{'leases_state_active'} if (!defined($state) || $state eq '' || $state eq '0'); return &text('leases_state_number', $state); } # kea_lease_summary(version) # Counts total, active, and inactive leases for dashboard statistics. sub kea_lease_summary { my ($ver) = @_; my ($leases, $err, $file) = &kea_read_leases($ver); my $active = 0; foreach my $lease (@$leases) { $active++ if (&kea_lease_is_active($lease)); } return { 'version' => $ver, 'file' => $file, 'error' => $err, 'total' => scalar(@$leases), 'active' => $active, 'inactive' => scalar(@$leases) - $active, }; } # kea_pool_usage_rows(version) # Builds per-subnet active-lease counts for the pool usage view. sub kea_pool_usage_rows { my ($ver) = @_; my (undef, $root, undef, $err) = &kea_read_dhcp_config($ver); return ([ ], $err) if ($err); my ($leases, $lerr) = &kea_active_leases($ver); return ([ ], $lerr) if ($lerr && !@$leases); my %count; foreach my $lease (@$leases) { my $id = $lease->{'subnet_id'} || $lease->{'subnet'}; $count{$id}++ if (defined($id) && $id ne ''); } my @rows; foreach my $entry (&kea_all_subnets($root, $ver)) { my $subnet = $entry->{'subnet'}; my $id = $subnet->{'id'} || ""; push(@rows, { 'id' => $id, 'subnet' => $subnet->{'subnet'} || "", 'pools' => ref($subnet->{'pools'}) eq 'ARRAY' ? scalar(@{$subnet->{'pools'}}) : 0, 'pd_pools' => ref($subnet->{'pd-pools'}) eq 'ARRAY' ? scalar(@{$subnet->{'pd-pools'}}) : 0, 'reservations' => ref($subnet->{'reservations'}) eq 'ARRAY' ? scalar(@{$subnet->{'reservations'}}) : 0, 'active' => $count{$id} || 0, }); } return (\@rows, undef); } # kea_recent_component_log_lines(&component, [lines]) # Returns recent journal lines for a component when systemd logs are available. sub kea_recent_component_log_lines { my ($c, $lines) = @_; my $journalctl = &has_command('journalctl'); my $unit = &kea_component_systemd_unit($c); return [ ] if (!$journalctl || !$unit); my @logs = &kea_recent_unique_lines(&kea_journal_lines( $journalctl, $unit, "", $lines || 20)); return \@logs; } # kea_scope_name(&scope, fallback) # Returns a display name for a shared network or subnet-like object. sub kea_scope_name { my ($scope, $fallback) = @_; return $scope->{'name'} || $scope->{'subnet'} || $fallback || ""; } # kea_get_comment(&scope) # Reads the Webmin-managed comment from Kea user-context. sub kea_get_comment { my ($scope) = @_; return ref($scope->{'user-context'}) eq 'HASH' ? $scope->{'user-context'}->{'comment'} : undef; } # kea_set_comment(&scope, comment) # Stores or removes the Webmin-managed comment in Kea user-context. sub kea_set_comment { my ($scope, $comment) = @_; $comment =~ s/^\s+|\s+$//g if (defined($comment)); # Kea stores human comments in user-context; clean up the wrapper when our # comment is the last value left. if (!defined($comment) || $comment eq '') { delete($scope->{'user-context'}->{'comment'}) if (ref($scope->{'user-context'}) eq 'HASH'); delete($scope->{'user-context'}) if (ref($scope->{'user-context'}) eq 'HASH' && !keys(%{$scope->{'user-context'}})); } else { $scope->{'user-context'} = { } if (ref($scope->{'user-context'}) ne 'HASH'); $scope->{'user-context'}->{'comment'} = $comment; } } # kea_count_array(&scope, key) # Safely counts an array field on a Kea config object. sub kea_count_array { my ($scope, $key) = @_; return ref($scope->{$key}) eq 'ARRAY' ? scalar(@{$scope->{$key}}) : 0; } # kea_set_optional(&hash, key, value) # Stores a form value as a scalar, deleting empty/default values. sub kea_set_optional { my ($hash, $key, $value) = @_; $value = &kea_trim_form_value($value); # Empty form fields mean "inherit/default/unset" in Kea, so remove the key. if ($value eq '') { delete($hash->{$key}); } elsif ($value =~ /^\d+$/) { $hash->{$key} = int($value); } else { $hash->{$key} = $value; } } # kea_set_optional_string(&hash, key, value) # Stores a form value as a JSON string, even when it looks numeric. sub kea_set_optional_string { my ($hash, $key, $value) = @_; $value = &kea_trim_form_value($value); if ($value eq '') { delete($hash->{$key}); } else { $hash->{$key} = $value; } } # kea_trim_form_value(value) # Normalizes a submitted scalar form value. sub kea_trim_form_value { my ($value) = @_; return "" if (!defined($value)); $value =~ s/^\s+|\s+$//g; return $value; } # kea_form_has_prefix(prefix) # Returns true when a submitted form includes fields for an optional section. sub kea_form_has_prefix { my ($prefix) = @_; foreach my $k (keys %in) { return 1 if (index($k, $prefix) == 0); } return 0; } # kea_set_optional_integer(&hash, key, value) # Stores an optional integer form value after validation. sub kea_set_optional_integer { my ($hash, $key, $value) = @_; $value = &kea_trim_form_value($value); if ($value eq '') { delete($hash->{$key}); } elsif ($value =~ /^\d+$/) { $hash->{$key} = int($value); } else { &error(&text('field_enumber', $text{'field_'.$key} || $key)); } } # kea_validate_lifetimes(&hash) # Validates timer ordering for lease lifetime fields. sub kea_validate_lifetimes { my ($hash) = @_; # Kea accepts these timers independently, but the UI should prevent impossible # lease timing relationships before saving. foreach my $pair ([ 'renew-timer', 'rebind-timer' ], [ 'rebind-timer', 'valid-lifetime' ], [ 'min-valid-lifetime', 'valid-lifetime' ], [ 'valid-lifetime', 'max-valid-lifetime' ]) { my ($low, $high) = @$pair; next if (!defined($hash->{$low}) || !defined($hash->{$high})); &error(&text('field_eorder', $text{'field_'.$low} || $low, $text{'field_'.$high} || $high)) if ($hash->{$low} >= $hash->{$high}); } } # kea_json_bool(value) # Returns a JSON boolean object compatible with Webmin's JSON encoder. sub kea_json_bool { my ($value) = @_; eval { require JSON::PP }; return $value ? JSON::PP::true() : JSON::PP::false(); } # kea_set_optional_bool(&hash, key, value) # Stores an optional boolean form value after validation. sub kea_set_optional_bool { my ($hash, $key, $value) = @_; $value = &kea_trim_form_value($value); if ($value eq '') { delete($hash->{$key}); } elsif ($value eq 'true' || $value eq '1') { $hash->{$key} = &kea_json_bool(1); } elsif ($value eq 'false' || $value eq '0') { $hash->{$key} = &kea_json_bool(0); } else { &error(&text('field_ebool', $text{'field_'.$key} || $key)); } } # kea_bool_value(value) # Converts a JSON boolean-ish value back to the UI select value. sub kea_bool_value { my ($value) = @_; return '' if (!defined($value)); return $value ? 'true' : 'false'; } # kea_relay_addresses(&hash) # Returns relay addresses from either old or current Kea relay syntax. sub kea_relay_addresses { my ($hash) = @_; my $relay = ref($hash->{'relay'}) eq 'HASH' ? $hash->{'relay'} : { }; return @{$relay->{'ip-addresses'}} if (ref($relay->{'ip-addresses'}) eq 'ARRAY'); return ($relay->{'ip-address'}) if ($relay->{'ip-address'}); return ( ); } # kea_set_relay_addresses(&hash, text) # Stores relay IP addresses using Kea's ip-addresses list form. sub kea_set_relay_addresses { my ($hash, $text) = @_; my @addrs = grep { $_ ne '' } split(/[,\s]+/, $text || ""); if (@addrs) { # Always write the modern ip-addresses list form even if older configs used the # singular ip-address field. $hash->{'relay'} = { 'ip-addresses' => \@addrs }; } else { delete($hash->{'relay'}); } } # kea_ipv4_canonical_subnet(cidr) # Canonicalizes an IPv4 subnet CIDR by clearing host bits. sub kea_ipv4_canonical_subnet { my ($cidr) = @_; return if ($cidr !~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\/(\d+)$/); my @o = ($1, $2, $3, $4); my $prefix = $5; return if (grep { $_ > 255 } @o); return if ($prefix > 32); my $ip = ($o[0] << 24) | ($o[1] << 16) | ($o[2] << 8) | $o[3]; my $mask = $prefix == 0 ? 0 : (0xffffffff << (32 - $prefix)) & 0xffffffff; my $net = $ip & $mask; # Normalize 192.0.2.1/24 to 192.0.2.0/24 to avoid ambiguous subnet selection. return join(".", (($net >> 24) & 255, ($net >> 16) & 255, ($net >> 8) & 255, $net & 255))."/".$prefix; } # kea_ipv4_mask_from_subnet(cidr) # Calculates the dotted IPv4 subnet mask for a CIDR prefix. sub kea_ipv4_mask_from_subnet { my ($cidr) = @_; return "" if ($cidr !~ /\/(\d+)$/ || $1 > 32); my $prefix = $1; my $mask = $prefix == 0 ? 0 : (0xffffffff << (32 - $prefix)) & 0xffffffff; return join(".", (($mask >> 24) & 255, ($mask >> 16) & 255, ($mask >> 8) & 255, $mask & 255)); } # kea_canonical_subnet(cidr, version) # Applies protocol-specific subnet canonicalization. sub kea_canonical_subnet { my ($cidr, $ver) = @_; return $ver == 4 ? &kea_ipv4_canonical_subnet($cidr) : $cidr; } # kea_common_options(version) # Returns the curated common DHCP option-data fields for a protocol. sub kea_common_options { my ($ver) = @_; # Keep only broadly useful option-data fields here. Less-common and vendor # options remain available through the additional option-data grid. return $ver == 6 ? ( [ 'dns-servers', $text{'opt_common_dns-servers'}, 46, 23 ], [ 'domain-search', $text{'opt_common_domain-search'}, 46, 24 ], [ 'sntp-servers', $text{'opt_common_sntp-servers'}, 46, 31 ], [ 'preference', $text{'opt_common_preference'}, 10, 7 ], [ 'unicast', $text{'opt_common_unicast'}, 40, 12 ], [ 'bootfile-url', $text{'opt_common_bootfile-url'}, 60, 59 ], [ 'bootfile-param', $text{'opt_common_bootfile-param'}, 60, 60 ], [ 'new-posix-timezone', $text{'opt_common_new-posix-timezone'}, 46, 41 ], [ 'new-tzdb-timezone', $text{'opt_common_new-tzdb-timezone'}, 32, 42 ], ) : ( [ 'routers', $text{'opt_common_routers'}, 46, 3 ], [ 'broadcast-address', $text{'opt_common_broadcast-address'}, 20, 28 ], [ 'domain-name', $text{'opt_common_domain-name'}, 40, 15 ], [ 'domain-name-servers', $text{'opt_common_domain-name-servers'}, 46, 6 ], [ 'domain-search', $text{'opt_common_domain-search'}, 46, 119 ], [ 'ntp-servers', $text{'opt_common_ntp-servers'}, 46, 42 ], [ 'time-servers', $text{'opt_common_time-servers'}, 46, 4 ], [ 'log-servers', $text{'opt_common_log-servers'}, 46, 7 ], [ 'root-path', $text{'opt_common_root-path'}, 46, 17 ], [ 'tftp-server-name', $text{'opt_common_tftp-server-name'}, 46, 66 ], [ 'boot-file-name', $text{'opt_common_boot-file-name'}, 46, 67 ], [ 'nis-domain', $text{'opt_common_nis-domain'}, 40, 40 ], [ 'nis-servers', $text{'opt_common_nis-servers'}, 46, 41 ], [ 'netbios-name-servers', $text{'opt_common_netbios-name-servers'}, 46, 44 ], [ 'netbios-scope', $text{'opt_common_netbios-scope'}, 32, 47 ], [ 'netbios-node-type', $text{'opt_common_netbios-node-type'}, 10, 46 ], [ 'time-offset', $text{'opt_common_time-offset'}, 10, 2 ], ); } # kea_advanced_options(version) # Returns advanced option-data fields shown outside the common list. sub kea_advanced_options { my ($ver) = @_; return $ver == 4 ? ( [ 'dhcp-server-identifier', $text{'opt_common_dhcp-server-identifier'}, 20, 54 ], ) : ( ); } # kea_managed_options(version) # Returns option-data entries Kea manages automatically and Webmin must not edit. sub kea_managed_options { my ($ver) = @_; # Kea derives subnet-mask from the subnet prefix, so expose it read-only only. return $ver == 4 ? ( [ 'subnet-mask', 1 ], ) : ( ); } # kea_common_option_names(version) # Returns common option names for duplicate filtering and parsing. sub kea_common_option_names { my ($ver) = @_; return map { $_->[0] } &kea_common_options($ver); } # kea_common_option_codes(version) # Returns common option codes for duplicate filtering and parsing. sub kea_common_option_codes { my ($ver) = @_; return map { $_->[3] } grep { defined($_->[3]) } &kea_common_options($ver); } # kea_advanced_option_names(version) # Returns advanced option names for duplicate filtering and parsing. sub kea_advanced_option_names { my ($ver) = @_; return map { $_->[0] } &kea_advanced_options($ver); } # kea_advanced_option_codes(version) # Returns advanced option codes for duplicate filtering and parsing. sub kea_advanced_option_codes { my ($ver) = @_; return map { $_->[3] } grep { defined($_->[3]) } &kea_advanced_options($ver); } # kea_managed_option_names(version) # Returns auto-managed option names that cannot be edited directly. sub kea_managed_option_names { my ($ver) = @_; return map { $_->[0] } &kea_managed_options($ver); } # kea_managed_option_codes(version) # Returns auto-managed option codes that cannot be edited directly. sub kea_managed_option_codes { my ($ver) = @_; return map { $_->[1] } &kea_managed_options($ver); } # kea_option_code(version, name) # Looks up a known DHCP option code by name. sub kea_option_code { my ($ver, $name) = @_; foreach my $o (&kea_common_options($ver), &kea_advanced_options($ver)) { return $o->[3] if ($o->[0] eq $name && defined($o->[3])); } return; } # kea_option_name(version, code) # Looks up a known DHCP option name by code. sub kea_option_name { my ($ver, $code) = @_; foreach my $o (&kea_common_options($ver), &kea_advanced_options($ver)) { return $o->[0] if (defined($o->[3]) && defined($code) && $o->[3] == $code); } return; } # kea_known_option(&option, version) # Returns true when an option-data row maps to a named UI field. sub kea_known_option { my ($o, $ver) = @_; return 0 if (ref($o) ne 'HASH'); return 1 if ($o->{'name'} && &indexof($o->{'name'}, (&kea_common_option_names($ver), &kea_advanced_option_names($ver))) >= 0); return 1 if (defined($o->{'code'}) && &kea_option_name($ver, $o->{'code'})); return 0; } # kea_same_known_option(&option, name, code) # Compares an option-data row with a known option by name or code. sub kea_same_known_option { my ($o, $name, $code) = @_; return 0 if (ref($o) ne 'HASH'); return 1 if ($name ne '' && defined($o->{'name'}) && $o->{'name'} eq $name); return 1 if (defined($code) && defined($o->{'code'}) && $o->{'code'} == $code); return 0; } # kea_option_value(&options, name, [version]) # Reads the data value for a known option-data entry. sub kea_option_value { my ($opts, $name, $ver) = @_; $opts = [ ] if (ref($opts) ne 'ARRAY'); my $code = defined($ver) ? &kea_option_code($ver, $name) : undef; # Match by either canonical name or known option code so numeric configs still # populate named UI fields. foreach my $o (@$opts) { return $o->{'data'} if (ref($o) eq 'HASH' && (defined($o->{'name'}) && $o->{'name'} eq $name || defined($code) && defined($o->{'code'}) && $o->{'code'} == $code)); } return ""; } # kea_set_option_value(&options, version, name, value, [&new-option]) # Updates or removes one known option-data entry. sub kea_set_option_value { my ($opts, $ver, $name, $value, $newopt) = @_; $opts = [ ] if (ref($opts) ne 'ARRAY'); my $code = &kea_option_code($ver, $name); my ($found, @keep); # Replace all existing entries for this known option with at most one updated # entry, preserving unrelated option-data rows. foreach my $o (@$opts) { if (&kea_same_known_option($o, $name, $code)) { if (!$found && defined($value) && $value ne '') { my %copy = ref($o) eq 'HASH' ? %$o : ( ); $copy{'name'} = $name if (!$copy{'name'} && !defined($copy{'code'})); $copy{'data'} = $value; push(@keep, \%copy); $found = 1; } } else { push(@keep, $o); } } if (!$found && defined($value) && $value ne '') { my %copy = ref($newopt) eq 'HASH' ? %$newopt : ( 'name' => $name, 'data' => $value ); # Prefer the original representation when a numeric option row was # promoted into a named field. $copy{'data'} = $value; $copy{'name'} = $name if (!$copy{'name'} && !defined($copy{'code'})); push(@keep, \%copy); } @$opts = @keep; } # kea_other_options(&options, version) # Returns option-data rows not represented by named fields. sub kea_other_options { my ($opts, $ver) = @_; $opts = [ ] if (ref($opts) ne 'ARRAY'); # The free-form option grid should contain only entries not already represented # by named/common fields and not managed automatically by Kea. my %known = map { $_ => 1 } (&kea_common_option_names($ver), &kea_advanced_option_names($ver), &kea_managed_option_names($ver)); my %known_codes = map { $_ => 1 } (&kea_common_option_codes($ver), &kea_advanced_option_codes($ver), &kea_managed_option_codes($ver)); return [ grep { ref($_) eq 'HASH' && !(defined($_->{'name'}) && $known{$_->{'name'}}) && !(defined($_->{'code'}) && $known_codes{$_->{'code'}}) } @$opts ]; } # kea_common_option_rows(&options, version, prefix) # Renders common option-data form rows for a scope. sub kea_common_option_rows { my ($opts, $ver, $prefix) = @_; print &ui_table_start($text{'options_common'}, "width=100%", 4); # The metadata list drives both labels and field names so DHCPv4/DHCPv6 can # share the same rendering code without copying option tables. foreach my $o (&kea_common_options($ver)) { my ($name, $label, $size) = @$o; print &ui_table_row(&kea_option_hlink($name, $label), &ui_textbox($prefix.$name, &kea_option_value($opts, $name, $ver), $size || 40)); } print &ui_table_end(); } # kea_advanced_option_rows(&options, version, prefix) # Renders advanced option-data form rows for a scope. sub kea_advanced_option_rows { my ($opts, $ver, $prefix) = @_; return if ($ver != 4); # The advanced option list is intentionally small and DHCPv4-only. These are # valid option-data entries but are risky enough to stay off the common tab. foreach my $o (&kea_advanced_options($ver)) { my ($name, $label, $size) = @$o; print &ui_table_row(&kea_option_hlink($name, $label), &ui_textbox($prefix.$name, &kea_option_value($opts, $name, $ver), $size || 40)); } } # kea_option_hlink(option-name, [label]) # Returns a standard Webmin help link for a Kea option-data field. sub kea_option_hlink { my ($name, $label) = @_; return &hlink($label || $name, &kea_help_id("opt", $name)); } # kea_field_hlink(field-name, [label]) # Returns a standard Webmin help link for a structured Kea object field. sub kea_field_hlink { my ($name, $label) = @_; return &hlink($label || $text{'field_'.$name} || $name, &kea_help_id("field", $name)); } # kea_help_id(prefix, name) # Maps Kea's dash-heavy option and field names to help file basenames. sub kea_help_id { my ($prefix, $name) = @_; $name =~ s/[^A-Za-z0-9]+/_/g; $name =~ s/^_+//; $name =~ s/_+$//; return $prefix."_".$name; } # kea_option_data_rows(&options, prefix, version) # Renders the generic option-data editor grid. sub kea_option_data_rows { my ($opts, $prefix, $ver) = @_; $opts = &kea_other_options($opts, $ver) if ($ver); $opts = [ ] if (ref($opts) ne 'ARRAY'); # option-data rows can contain long strings, so keep them inside the same # wrapper used by other wide row-based editors in this module. print &ui_tag_start('div', { 'class' => 'option-data-table' }); print &ui_columns_start([ &kea_field_hlink('option-name', $text{'opt_name'}), &kea_field_hlink('option-code', $text{'opt_code'}), &kea_field_hlink('option-space', $text{'opt_space'}), &kea_field_hlink('option-data', $text{'opt_data'}) ], 100); my $rows = @$opts + 3; for(my $i=0; $i<$rows; $i++) { my $o = $opts->[$i] || { }; print &ui_columns_row([ &ui_textbox($prefix."name_$i", $o->{'name'} || "", 24), &ui_textbox($prefix."code_$i", $o->{'code'} || "", 6), &ui_textbox($prefix."space_$i", $o->{'space'} || "", 12), &ui_textbox($prefix."data_$i", $o->{'data'} || "", 45), ]); } print &ui_columns_end(); print &ui_tag_end('div'); } # kea_option_data_section(&options, prefix, version) # Renders the generic option-data section when it has content or is required. sub kea_option_data_section { my ($opts, $prefix, $ver, $always) = @_; my $other = &kea_other_options($opts, $ver); return if (!@$other && !$always); print &ui_subheading($text{'options_custom'}); print &ui_div($text{'options_custom_desc'}); &kea_option_data_rows($other, $prefix); } # kea_ddns_domains(&root, section-name) # Returns D2 forward or reverse domain rows without forcing missing sections. sub kea_ddns_domains { my ($root, $section) = @_; my $conf = ref($root->{$section}) eq 'HASH' ? $root->{$section} : { }; return ref($conf->{'ddns-domains'}) eq 'ARRAY' ? $conf->{'ddns-domains'} : [ ]; } # kea_ddns_listener_endpoint(&root) # Returns the visible D2 listener endpoint as separate host and port strings. sub kea_ddns_listener_endpoint { my ($root) = @_; my $host = $root->{'ip-address'} || ""; my $port = defined($root->{'port'}) ? $root->{'port'} : ""; return ($host, $port); } # kea_ddns_listener_target(&root) # Returns the D2 listener as host:port text for display and comparison. sub kea_ddns_listener_target { my ($root) = @_; my ($host, $port) = &kea_ddns_listener_endpoint($root); return "" if ($host eq '' && $port eq ''); return $host.($port ne '' ? ":".$port : ""); } # kea_ddns_listener_host(&root) # Returns the normalized D2 listener host without IPv6 brackets. sub kea_ddns_listener_host { my ($root) = @_; my ($host) = &kea_ddns_listener_endpoint($root); $host = lc(&kea_trim_form_value($host)); $host =~ s/^\[(.*)\]$/$1/; return $host; } # kea_ddns_listener_loopback(&root) # Returns true for addresses that still accept only local D2 requests. sub kea_ddns_listener_loopback { my ($root) = @_; my $host = &kea_ddns_listener_host($root); return 0 if ($host eq ''); return 1 if ($host eq 'localhost' || $host eq '::1'); return $host =~ /^127(?:\.\d{1,3}){3}$/ ? 1 : 0; } # kea_ddns_listener_non_default_loopback(&root) # 127.0.0.2 and similar are local, but DHCP sender targets must match exactly. sub kea_ddns_listener_non_default_loopback { my ($root) = @_; return 0 if (!&kea_ddns_listener_loopback($root)); my $host = &kea_ddns_listener_host($root); return $host ne '127.0.0.1' && $host ne '::1' && $host ne 'localhost'; } # kea_ddns_listener_non_loopback(&root) # D2 should normally only receive name-change requests from local Kea daemons. sub kea_ddns_listener_non_loopback { my ($root) = @_; my $host = &kea_ddns_listener_host($root); return 0 if ($host eq ''); return &kea_ddns_listener_loopback($root) ? 0 : 1; } # kea_ddns_domain_server_fields(&domain) # Flattens D2 server addresses and only shows a port when it is safe to edit as # one shared value. Mixed per-server ports are preserved by leaving it blank. sub kea_ddns_domain_server_fields { my ($domain) = @_; my $servers = ref($domain->{'dns-servers'}) eq 'ARRAY' ? $domain->{'dns-servers'} : [ ]; my @addrs; my ($port, $mixed_port, $server_without_port); foreach my $s (@$servers) { next if (ref($s) ne 'HASH'); push(@addrs, $s->{'ip-address'}) if ($s->{'ip-address'}); if (defined($s->{'port'})) { if (!defined($port)) { $port = $s->{'port'}; $mixed_port = 1 if ($server_without_port); } elsif ($port ne $s->{'port'}) { $mixed_port = 1; } } else { $server_without_port = 1; $mixed_port = 1; } } return (join(" ", @addrs), !$mixed_port && defined($port) ? $port : "", $mixed_port ? 1 : 0); } # kea_ddns_domain_rows(&domains, prefix) # Renders the D2 forward/reverse DNS update domain table. sub kea_ddns_domain_rows { my ($domains, $prefix) = @_; $domains = [ ] if (ref($domains) ne 'ARRAY'); print &ui_tag_start('div', { 'class' => 'option-data-table' }); print &ui_columns_start([ &kea_field_hlink('ddns-domain-name', $text{'ddns_domain_name'}), &kea_field_hlink('ddns-domain-key', $text{'ddns_domain_key'}), &kea_field_hlink('ddns-domain-servers', $text{'ddns_domain_servers'}), &kea_field_hlink('ddns-domain-port', $text{'ddns_domain_port'}) ], 100); # D2 domains are array entries. Keep a few empty rows so new domains can be # added without a separate "add row" round trip. my $rows = @$domains + 3; for(my $i=0; $i<$rows; $i++) { my $d = ref($domains->[$i]) eq 'HASH' ? $domains->[$i] : { }; my ($servers, $port, $mixed_port) = &kea_ddns_domain_server_fields($d); my $port_field = &ui_textbox($prefix."port_$i", $port, 7); if ($mixed_port) { $port_field .= " ".&ui_tag('small', $text{'ddns_mixed_ports'}, { 'style' => 'color:var(--text-color-light, #777)' }); } print &ui_columns_row([ &ui_textbox($prefix."name_$i", $d->{'name'} || "", 28), &ui_textbox($prefix."key_$i", $d->{'key-name'} || "", 20), &ui_textbox($prefix."servers_$i", $servers, 42), $port_field, ]); } print &ui_columns_end(); print &ui_tag_end('div'); } # kea_select_options(current-value, default-label, value...) # Builds a conservative select list without losing uncommon existing values. sub kea_select_options { my ($current, $default_label, @values) = @_; my @opts = ([ "", $default_label ]); my %known = ( '' => 1 ); foreach my $v (@values) { push(@opts, [ $v, $v ]); $known{$v} = 1; } if (defined($current) && $current ne '' && !$known{$current}) { push(@opts, [ $current, $current ]); } return \@opts; } # kea_tsig_algorithm_options(current-value) # Builds the TSIG algorithm select list while preserving unusual existing values. sub kea_tsig_algorithm_options { my ($current) = @_; return &kea_select_options($current, $text{'socket_default'}, 'hmac-sha256', 'hmac-sha384', 'hmac-sha512', 'hmac-sha224', 'hmac-sha1', 'hmac-md5'); } # kea_tsig_key_names(&keys) # Returns configured TSIG key names for DDNS domain validation. sub kea_tsig_key_names { my ($keys) = @_; my %names; foreach my $key (@{ref($keys) eq 'ARRAY' ? $keys : [ ]}) { next if (ref($key) ne 'HASH' || !$key->{'name'}); $names{$key->{'name'}} = 1; } return \%names; } # kea_parse_ddns_domain_rows(&existing-domains, prefix, [&tsig-keys]) # Parses D2 domain rows while preserving unexposed keys by row index. sub kea_parse_ddns_domain_rows { my ($domains, $prefix, $keys) = @_; $domains = [ ] if (ref($domains) ne 'ARRAY'); my $keynames = ref($keys) eq 'ARRAY' ? &kea_tsig_key_names($keys) : undef; my @parsed; # Rebuild only submitted rows while retaining unexposed per-domain properties # from the row's existing object. for(my $i=0; defined($in{$prefix."name_$i"}) || defined($in{$prefix."key_$i"}) || defined($in{$prefix."servers_$i"}) || defined($in{$prefix."port_$i"}); $i++) { my $name = &kea_trim_form_value($in{$prefix."name_$i"}); my $key = &kea_trim_form_value($in{$prefix."key_$i"}); my $servers = &kea_trim_form_value($in{$prefix."servers_$i"}); my $port = &kea_trim_form_value($in{$prefix."port_$i"}); next if ($name eq '' && $key eq '' && $servers eq '' && $port eq ''); &error($text{'ddns_edomain'}) if ($name eq ''); &error($text{'ddns_eserver'}) if ($servers eq ''); &error($text{'ddns_eport'}) if ($port ne '' && $port !~ /^\d+$/); &error(&text('ddns_ekey_unknown', $key)) if ($key ne '' && $keynames && !$keynames->{$key}); my %domain = ref($domains->[$i]) eq 'HASH' ? %{$domains->[$i]} : ( ); &kea_set_optional_string(\%domain, 'name', $name); &kea_set_optional_string(\%domain, 'key-name', $key); my @addrs = grep { $_ ne '' } split(/[,\s]+/, $servers); foreach my $addr (@addrs) { &error(&text('ddns_eaddr', &html_escape($addr))) if (!&check_ipaddress($addr) && !&check_ip6address($addr)); } if (@addrs) { my @old = ref($domain{'dns-servers'}) eq 'ARRAY' ? @{$domain{'dns-servers'}} : ( ); my @newservers; for(my $j=0; $j<@addrs; $j++) { my %server = ref($old[$j]) eq 'HASH' ? %{$old[$j]} : ( ); $server{'ip-address'} = $addrs[$j]; if ($port ne '') { $server{'port'} = int($port); } elsif (!defined($server{'port'})) { $server{'port'} = 53; } push(@newservers, \%server); } $domain{'dns-servers'} = \@newservers; } else { delete($domain{'dns-servers'}); } push(@parsed, \%domain); } return \@parsed; } # kea_tsig_key_rows(&keys, prefix) # Renders D2 TSIG keys used by DNS update domains. sub kea_tsig_key_rows { my ($keys, $prefix) = @_; $keys = [ ] if (ref($keys) ne 'ARRAY'); print &ui_tag_start('div', { 'class' => 'option-data-table' }); print &ui_columns_start([ &kea_field_hlink('tsig-key-name', $text{'tsig_key_name'}), &kea_field_hlink('tsig-key-algorithm', $text{'tsig_key_algorithm'}), &kea_field_hlink('tsig-key-secret', $text{'tsig_key_secret'}) ], 100); # Existing secrets are never echoed back into the browser. Leaving the password # field empty keeps the old secret during save. my $rows = @$keys + 3; for(my $i=0; $i<$rows; $i++) { my $key = ref($keys->[$i]) eq 'HASH' ? $keys->[$i] : { }; print &ui_columns_row([ &ui_textbox($prefix."name_$i", $key->{'name'} || "", 24), &ui_select($prefix."algorithm_$i", $key->{'algorithm'} || "", &kea_tsig_algorithm_options($key->{'algorithm'})), &ui_password($prefix."secret_$i", "", 44), ]); } print &ui_columns_end(); print &ui_tag_end('div'); } # kea_parse_tsig_key_rows(&existing-keys, prefix) # Parses TSIG key rows while preserving existing secrets unless replaced. sub kea_parse_tsig_key_rows { my ($keys, $prefix) = @_; $keys = [ ] if (ref($keys) ne 'ARRAY'); my @parsed; # Empty rows are ignored. A visible name with no algorithm is rejected because # Kea requires every TSIG key to declare an algorithm. for(my $i=0; defined($in{$prefix."name_$i"}) || defined($in{$prefix."algorithm_$i"}) || defined($in{$prefix."secret_$i"}); $i++) { my $name = &kea_trim_form_value($in{$prefix."name_$i"}); my $algorithm = &kea_trim_form_value($in{$prefix."algorithm_$i"}); my $secret = &kea_trim_form_value($in{$prefix."secret_$i"}); next if ($name eq '' && $algorithm eq '' && $secret eq ''); &error($text{'ddns_ekey'}) if ($name eq ''); &error($text{'ddns_ekey_algorithm'}) if ($algorithm eq ''); my %key = ref($keys->[$i]) eq 'HASH' ? %{$keys->[$i]} : ( ); &kea_set_optional_string(\%key, 'name', $name); &kea_set_optional_string(\%key, 'algorithm', $algorithm); $key{'secret'} = $secret if ($secret ne ''); push(@parsed, \%key); } return \@parsed; } # kea_logger_rows(&loggers, prefix) # Renders the common fields from Kea's root-level loggers array. sub kea_logger_rows { my ($loggers, $prefix) = @_; $loggers = [ ] if (ref($loggers) ne 'ARRAY'); print &ui_tag_start('div', { 'class' => 'option-data-table' }); print &ui_columns_start([ &kea_field_hlink('logger-name', $text{'logging_name'}), &kea_field_hlink('logger-severity', $text{'logging_severity'}), &kea_field_hlink('logger-debuglevel', $text{'logging_debuglevel'}), &kea_field_hlink('logger-output', $text{'logging_output'}), &kea_field_hlink('logger-pattern', $text{'logging_pattern'}) ], 100); # Existing logger rows are shown first, with spare rows for adding more # loggers. Multiple output-options are preserved, but the UI edits the first. my $rows = @$loggers + 2; for(my $i=0; $i<$rows; $i++) { my $logger = ref($loggers->[$i]) eq 'HASH' ? $loggers->[$i] : { }; my $outputs = ref($logger->{'output-options'}) eq 'ARRAY' ? $logger->{'output-options'} : [ ]; my $first = ref($outputs->[0]) eq 'HASH' ? $outputs->[0] : { }; print &ui_columns_row([ &ui_textbox($prefix."name_$i", $logger->{'name'} || "", 24), &kea_logger_severity_select($prefix."severity_$i", $logger->{'severity'} || ""), &ui_textbox($prefix."debuglevel_$i", defined($logger->{'debuglevel'}) ? $logger->{'debuglevel'} : "", 6), &ui_textbox($prefix."output_$i", $first->{'output'} || "", 24), &ui_textbox($prefix."pattern_$i", &kea_logger_display_value($first->{'pattern'}), 32), ]); } print &ui_columns_end(); print &ui_tag_end('div'); } # kea_logger_severity_select(name, value) # Renders the logger severity selector. sub kea_logger_severity_select { my ($name, $value) = @_; return &ui_select($name, $value, [ [ "", $text{'logging_default'} ], map { [ $_, $_ ] } qw(FATAL ERROR WARN INFO DEBUG) ]); } # kea_logger_display_value(value) # Shows control characters in compact text fields without losing intent. sub kea_logger_display_value { my ($value) = @_; return "" if (!defined($value)); $value =~ s/\\/\\\\/g; $value =~ s/\n/\\n/g; $value =~ s/\r/\\r/g; $value =~ s/\t/\\t/g; return $value; } # kea_logger_form_value(value) # Converts the visible escape form back to the value Kea expects in JSON. sub kea_logger_form_value { my ($value) = @_; $value = &kea_trim_form_value($value); $value =~ s/\\n/\n/g; $value =~ s/\\r/\r/g; $value =~ s/\\t/\t/g; $value =~ s/\\\\/\\/g; return $value; } # kea_parse_common_option_rows(&options, version, prefix) # Parses common option-data form fields back into option-data rows. sub kea_parse_common_option_rows { my ($opts, $ver, $prefix) = @_; $opts = [ ] if (ref($opts) ne 'ARRAY'); foreach my $name (&kea_common_option_names($ver)) { my $value = &kea_trim_form_value($in{$prefix.$name}); &kea_set_option_value($opts, $ver, $name, $value); } } # kea_parse_advanced_option_rows(&options, version, prefix) # Parses advanced option-data form fields back into option-data rows. sub kea_parse_advanced_option_rows { my ($opts, $ver, $prefix) = @_; $opts = [ ] if (ref($opts) ne 'ARRAY'); foreach my $name (&kea_advanced_option_names($ver)) { my $value = &kea_trim_form_value($in{$prefix.$name}); &kea_set_option_value($opts, $ver, $name, $value); } } # kea_parse_option_rows(prefix) # Parses generic option-data rows from submitted form fields. sub kea_parse_option_rows { my ($prefix) = @_; my @opts; # Stop at the first index where all row fields have disappeared from the form. for(my $i=0; defined($in{$prefix."name_$i"}) || defined($in{$prefix."code_$i"}) || defined($in{$prefix."data_$i"}); $i++) { my $name = &kea_trim_form_value($in{$prefix."name_$i"}); my $code = &kea_trim_form_value($in{$prefix."code_$i"}); my $data = &kea_trim_form_value($in{$prefix."data_$i"}); my $space = &kea_trim_form_value($in{$prefix."space_$i"}); next if ($name eq '' && $code eq '' && $data eq ''); &error($text{'opt_ename'}) if ($name eq '' && $code eq ''); &error(&text('opt_ecode', $code)) if ($code ne '' && $code !~ /^\d+$/); # Store the smallest valid option-data object; optional fields are added # only when the admin typed them. my %opt; $opt{'name'} = $name if ($name ne ''); $opt{'code'} = int($code) if ($code =~ /^\d+$/); $opt{'data'} = $data if ($data ne ''); $opt{'space'} = $space if ($space ne ''); push(@opts, \%opt); } return \@opts; } # kea_parse_other_option_rows(&options, version, prefix) # Merges generic option-data rows with named option rows. sub kea_parse_other_option_rows { my ($opts, $ver, $prefix) = @_; if (defined($in{$prefix."name_0"}) || defined($in{$prefix."code_0"}) || defined($in{$prefix."space_0"}) || defined($in{$prefix."data_0"})) { my $parsed = &kea_parse_option_rows($prefix); # Start with known options currently owned by named fields, then merge the # additional rows back in. This lets numeric known options round-trip cleanly. my %managed_names = map { $_ => 1 } &kea_managed_option_names($ver); my %managed_codes = map { $_ => 1 } &kea_managed_option_codes($ver); my @merged = grep { &kea_known_option($_, $ver) } @$opts; foreach my $o (@$parsed) { &error(&text('opt_emanaged', $o->{'name'})) if ($o->{'name'} && $managed_names{$o->{'name'}}); &error(&text('opt_emanaged', $o->{'code'})) if (defined($o->{'code'}) && $managed_codes{$o->{'code'}}); my $name = $o->{'name'} || ""; my $code = $o->{'code'}; $name ||= &kea_option_name($ver, $code) if (defined($code)); if ($name && &indexof($name, (&kea_common_option_names($ver), &kea_advanced_option_names($ver))) >= 0) { # A numeric row for a known option is promoted into the # named field's canonical storage instead of being rejected # as a duplicate. &kea_set_option_value(\@merged, $ver, $name, $o->{'data'}, $o); next; } push(@merged, $o); } return \@merged; } return $opts; } # kea_parse_logger_rows(&loggers, prefix) # Parses root-level Kea logger rows while preserving unexposed logger keys. sub kea_parse_logger_rows { my ($loggers, $prefix) = @_; $loggers = [ ] if (ref($loggers) ne 'ARRAY'); my @parsed; # A completely empty row is ignored. Non-empty rows require a logger name # because Kea uses the name to attach messages to the right logging channel. for(my $i=0; defined($in{$prefix."name_$i"}) || defined($in{$prefix."severity_$i"}) || defined($in{$prefix."debuglevel_$i"}) || defined($in{$prefix."output_$i"}) || defined($in{$prefix."pattern_$i"}); $i++) { my $name = &kea_trim_form_value($in{$prefix."name_$i"}); my $severity = &kea_trim_form_value($in{$prefix."severity_$i"}); my $debuglevel = &kea_trim_form_value($in{$prefix."debuglevel_$i"}); my $output = &kea_trim_form_value($in{$prefix."output_$i"}); my $pattern = &kea_logger_form_value($in{$prefix."pattern_$i"}); next if ($name eq '' && $severity eq '' && $debuglevel eq '' && $output eq '' && $pattern eq ''); &error($text{'logging_ename'}) if ($name eq ''); &error($text{'logging_edebug'}) if ($debuglevel ne '' && $debuglevel !~ /^\d+$/); &error($text{'logging_eseverity'}) if ($severity ne '' && &indexof($severity, qw(FATAL ERROR WARN INFO DEBUG)) < 0); &error($text{'logging_edebug_severity'}) if ($debuglevel ne '' && $debuglevel != 0 && $severity ne 'DEBUG'); my %logger = ref($loggers->[$i]) eq 'HASH' ? %{$loggers->[$i]} : ( ); $logger{'name'} = $name; if ($severity ne '') { $logger{'severity'} = $severity; } else { delete($logger{'severity'}); } if ($debuglevel ne '') { $logger{'debuglevel'} = int($debuglevel); } else { delete($logger{'debuglevel'}); } # Only the first output-options entry is edited by the UI. Additional # entries, if present, are kept after it. my @outputs = ref($logger{'output-options'}) eq 'ARRAY' ? @{$logger{'output-options'}} : ( ); my %first = ref($outputs[0]) eq 'HASH' ? %{$outputs[0]} : ( ); if ($output ne '') { $first{'output'} = $output; } else { delete($first{'output'}); } if ($pattern ne '') { $first{'pattern'} = $pattern; } else { delete($first{'pattern'}); } if (keys(%first)) { $outputs[0] = \%first; $logger{'output-options'} = \@outputs; } elsif (@outputs > 1) { shift(@outputs); $logger{'output-options'} = \@outputs; } else { delete($logger{'output-options'}); } push(@parsed, \%logger); } return \@parsed; } # kea_parse_pool_rows(prefix) # Parses DHCP address pool rows from submitted form fields. sub kea_parse_pool_rows { my ($prefix) = @_; my @pools; # Pool syntax varies between address families and can include ranges or CIDR. # Kea's native config test validates the final string. for(my $i=0; defined($in{$prefix."pool_$i"}); $i++) { my $pool = &kea_trim_form_value($in{$prefix."pool_$i"}); next if ($pool eq ''); push(@pools, { 'pool' => $pool }); } return \@pools; } # kea_parse_pd_pool_rows(prefix) # Parses DHCPv6 prefix-delegation pool rows. sub kea_parse_pd_pool_rows { my ($prefix) = @_; my @pools; # Prefix delegation is DHCPv6-only, but keeping the parser here lets the subnet # save handler stay protocol-neutral. for(my $i=0; defined($in{$prefix."prefix_$i"}) || defined($in{$prefix."prefix_len_$i"}) || defined($in{$prefix."delegated_len_$i"}); $i++) { my $pool_prefix = &kea_trim_form_value($in{$prefix."prefix_$i"}); my $plen = &kea_trim_form_value($in{$prefix."prefix_len_$i"}); my $dlen = &kea_trim_form_value($in{$prefix."delegated_len_$i"}); my $excluded = &kea_trim_form_value($in{$prefix."excluded_prefix_$i"}); my $elen = &kea_trim_form_value($in{$prefix."excluded_prefix_len_$i"}); next if ($pool_prefix eq '' && $plen eq '' && $dlen eq ''); my %pool; $pool{'prefix'} = $pool_prefix if ($pool_prefix ne ''); $pool{'prefix-len'} = int($plen) if ($plen =~ /^\d+$/); $pool{'delegated-len'} = int($dlen) if ($dlen =~ /^\d+$/); $pool{'excluded-prefix'} = $excluded if ($excluded ne ''); $pool{'excluded-prefix-len'} = int($elen) if ($elen =~ /^\d+$/); push(@pools, \%pool); } return \@pools; } # kea_parse_reservation_rows(prefix, version) # Parses host reservation rows for DHCPv4 or DHCPv6. sub kea_parse_reservation_rows { my ($prefix, $ver) = @_; my @reservations; # Reservations differ by protocol: DHCPv6 can assign multiple addresses and # delegated prefixes, while DHCPv4 stores a single ip-address value. for(my $i=0; defined($in{$prefix."type_$i"}) || defined($in{$prefix."identifier_$i"}) || defined($in{$prefix."address_$i"}); $i++) { my $type = &kea_trim_form_value($in{$prefix."type_$i"}) || ($ver == 6 ? 'duid' : 'hw-address'); my $identifier = &kea_trim_form_value($in{$prefix."identifier_$i"}); my $address = &kea_trim_form_value($in{$prefix."address_$i"}); my $hostname = &kea_trim_form_value($in{$prefix."hostname_$i"}); my $prefixes = &kea_trim_form_value($in{$prefix."prefixes_$i"}); next if ($identifier eq '' && $address eq '' && $hostname eq ''); my %r; $r{$type} = $identifier if ($identifier ne ''); if ($ver == 6) { my @addresses = grep { $_ ne '' } split(/\s*,\s*|\s+/, $address || ""); $r{'ip-addresses'} = \@addresses if (@addresses); my @prefixes = grep { $_ ne '' } split(/\s*,\s*|\s+/, $prefixes || ""); $r{'prefixes'} = \@prefixes if (@prefixes); } else { $r{'ip-address'} = $address if ($address ne ''); } $r{'hostname'} = $hostname if ($hostname ne ''); push(@reservations, \%r); } return \@reservations; } # kea_component_interfaces(&config) # Returns configured listen interfaces for a DHCP component. sub kea_component_interfaces { my ($root) = @_; my $ifaces = ref($root->{'interfaces-config'}) eq 'HASH' ? $root->{'interfaces-config'}->{'interfaces'} : undef; return $text{'iface_none'} if (ref($ifaces) ne 'ARRAY' || !@$ifaces); return join(", ", @$ifaces); } # kea_dhcp_subnet_count(&root, version) # Counts subnets across daemon-level and shared-network scopes. sub kea_dhcp_subnet_count { my ($root, $ver) = @_; my $subkey = &kea_subnet_key($ver); my @shareds = ref($root->{'shared-networks'}) eq 'ARRAY' ? @{$root->{'shared-networks'}} : ( ); my @subnets = ref($root->{$subkey}) eq 'ARRAY' ? @{$root->{$subkey}} : ( ); foreach my $s (@shareds) { push(@subnets, @{$s->{$subkey}}) if (ref($s->{$subkey}) eq 'ARRAY'); } return scalar(@subnets); } # kea_dhcp_has_listening_interfaces(&root) # Returns true when interfaces-config contains at least one interface. sub kea_dhcp_has_listening_interfaces { my ($root) = @_; my $ifaces = ref($root->{'interfaces-config'}) eq 'HASH' ? $root->{'interfaces-config'}->{'interfaces'} : undef; return ref($ifaces) eq 'ARRAY' && @$ifaces ? 1 : 0; } # kea_dhcp_needs_interface_warning(&root, version) # Returns true when subnets exist but no listening interfaces are configured. sub kea_dhcp_needs_interface_warning { my ($root, $ver) = @_; return &kea_dhcp_subnet_count($root, $ver) && !&kea_dhcp_has_listening_interfaces($root) ? 1 : 0; } # kea_component_summary(&component, &root) # Returns the services-table summary for a component config. sub kea_component_summary { my ($c, $root) = @_; if ($c->{'id'} eq 'dhcp4') { return &kea_dhcp_summary($root, 4); } elsif ($c->{'id'} eq 'dhcp6') { return &kea_dhcp_summary($root, 6); } elsif ($c->{'id'} eq 'ddns') { # DDNS configs are deep; the summary only reports whether # forward/reverse domain lists are present. my $forward = ref($root->{'forward-ddns'}) eq 'HASH' ? $root->{'forward-ddns'}->{'ddns-domains'} : undef; my $reverse = ref($root->{'reverse-ddns'}) eq 'HASH' ? $root->{'reverse-ddns'}->{'ddns-domains'} : undef; return &text('summary_ddns', &kea_yesno($forward), &kea_yesno($reverse)); } elsif ($c->{'id'} eq 'ctrl') { return &text('summary_ctrl', $root->{'http-host'} || "127.0.0.1", $root->{'http-port'} || "8000"); } return $text{'summary_empty'}; } # kea_dhcp_summary(&root, 4|6) # Summarizes DHCP subnets, pools, and reservations for one protocol. sub kea_dhcp_summary { my ($root, $ver) = @_; my $subkey = $ver == 6 ? 'subnet6' : 'subnet4'; # Count subnets both at the daemon level and inside shared networks because Kea # allows either storage location. my @shareds = ref($root->{'shared-networks'}) eq 'ARRAY' ? @{$root->{'shared-networks'}} : ( ); my @subnets = ref($root->{$subkey}) eq 'ARRAY' ? @{$root->{$subkey}} : ( ); foreach my $s (@shareds) { push(@subnets, @{$s->{$subkey}}) if (ref($s->{$subkey}) eq 'ARRAY'); } my ($pools, $pdpools, $reservations) = (0, 0, 0); foreach my $s (@subnets) { $pools += @{$s->{'pools'}} if (ref($s->{'pools'}) eq 'ARRAY'); $pdpools += @{$s->{'pd-pools'}} if (ref($s->{'pd-pools'}) eq 'ARRAY'); $reservations += @{$s->{'reservations'}} if (ref($s->{'reservations'}) eq 'ARRAY'); } return $ver == 6 ? &text('summary_dhcp6', scalar(@subnets), scalar(@shareds), $pools, $pdpools, $reservations) : &text('summary_dhcp4', scalar(@subnets), scalar(@shareds), $pools, $reservations); } # kea_yesno(value) # Returns the localized yes/no label for a boolean value. sub kea_yesno { my ($v) = @_; return $v ? $text{'yes'} : $text{'no'}; } # kea_action_command(action) # Builds the command used by global start, stop, and restart actions. sub kea_action_command { my ($action) = @_; my $cmd = &kea_config_value($action.'_cmd'); # Ignore packaged keactrl commands on systems where the Kea packages no longer # ship keactrl, and fall back to systemd units below. if ($cmd && $cmd =~ /\bkeactrl\b/ && !&has_command(&kea_config_value('keactrl_path')) && !&has_command('keactrl')) { $cmd = undef; } if ($cmd && $cmd =~ /^systemctl\b/ && !&has_command('systemctl')) { $cmd = undef; } if (!$cmd) { my $systemctl = &has_command('systemctl'); if ($systemctl) { my $verb = $action eq 'restart' ? 'restart' : $action; my @units = grep { $_ } map { &kea_component_systemd_unit($_) } &kea_components(); # Act on all Kea units together because the header action buttons # are global. $cmd = "e_path($systemctl)." ".$verb." ". join(" ", @units); } } if (!$cmd) { my $keactrl = &has_command(&kea_config_value('keactrl_path')) || &has_command('keactrl'); if ($keactrl) { my $kcmd = $action eq 'restart' ? 'reload' : $action; $cmd = "e_path($keactrl)." ".$kcmd; } } return $cmd; } # kea_run_action(action) # Executes a global Kea service action and returns any failure text. sub kea_run_action { my ($action) = @_; my $cmd = &kea_action_command($action); return $text{'action_ecmd'} if (!$cmd); # Return formatted command output only on failure; successful actions redirect # back to the module index with a Webmin log entry. my $out = &backquote_logged("$cmd 2>&1"); if ($?) { return &ui_tag('pre', &html_escape($out)); } return; } # get_all_config_files() # Returns config files that Webmin should include in module backups. sub get_all_config_files { my @rv; foreach my $c (&kea_components()) { my $file = &kea_config_file($c); next if (!$file); push(@rv, $file); # Backups should include files pulled in by Kea include directives. push(@rv, &kea_config_includes($file, 0)) if (-r $file); } # The Control Agent can keep API credentials in a separate password file. # Include it with the config backup so a restore can bring the service back. push(@rv, &kea_control_agent_password_files()); return &unique(@rv); } # kea_config_includes(file, depth) # Finds Kea include files so backups cover all referenced config fragments. sub kea_config_includes { my ($file, $depth) = @_; return ( ) if ($depth > 10); my $text = &read_file_contents($file); return ( ) if (!defined($text)); my $dir = &kea_dirname($file); my @rv; # Keep include discovery parallel to parse-time expansion so backup coverage # matches the files Kea would read. while($text =~ /<\?include\s+"([^"]+)"\s*\?>/g) { my $inc = $1 =~ /^\// ? $1 : -r "$dir/$1" ? "$dir/$1" : $1; push(@rv, $inc); push(@rv, &kea_config_includes($inc, $depth + 1)) if (-r $inc); } return @rv; } 1;
Save File
Cancel