webmin/bind8/t/run-tests.t

#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Cwd qw(abs_path);
use File::Temp qw(tempdir);

sub script_dir
{
    my $path = $0;
    if ($path =~ m{^/}) {
        $path =~ s{/[^/]+$}{};
        return $path;
    }
    my $cwd = `pwd`;
    chomp($cwd);
    if ($path =~ m{/}) {
        $path =~ s{/[^/]+$}{};
        return $cwd.'/'.$path;
    }
    return $cwd;
}

my $bindir = script_dir();
my $rootdir = abs_path("$bindir/../..") or die "rootdir: $!";

my $confdir = tempdir(CLEANUP => 1);
my $vardir = tempdir(CLEANUP => 1);

# Global Webmin config
open(my $cfh, ">", "$confdir/config") or die "config: $!";
print $cfh "os_type=linux\nos_version=0\n";
close($cfh);
open(my $vfh, ">", "$confdir/var-path") or die "var-path: $!";
print $vfh "$vardir\n";
close($vfh);

# Per-module config
mkdir "$confdir/bind8" or die "bind8 confdir: $!";
my $named_conf = "$confdir/named.conf";
open(my $mfh, ">", "$confdir/bind8/config") or die "bind8 config: $!";
print $mfh "named_conf=$named_conf\n";
print $mfh "named_path=/usr/sbin/named\n";
print $mfh "short_names=0\n";
print $mfh "ipv6_mode=1\n";
print $mfh "spf_record=0\n";
print $mfh "soa_style=0\n";
print $mfh "soa_start=0\n";
print $mfh "updserial_on=1\n";
print $mfh "allow_underscore=0\n";
print $mfh "allow_wild=1\n";
close($mfh);

# Avoid spawning `named -v`: bind8-lib reads version from this file.
open(my $verfh, ">", "$confdir/bind8/version") or die "version: $!";
print $verfh "9.18.0\n";
close($verfh);

$ENV{'WEBMIN_CONFIG'} = $confdir;
$ENV{'WEBMIN_VAR'} = $vardir;
$ENV{'FOREIGN_MODULE_NAME'} = 'bind8';
$ENV{'FOREIGN_ROOT_DIRECTORY'} = $rootdir;

chdir("$bindir/..") or die "chdir: $!";

require "$bindir/../bind8-lib.pl";
our (%config, %access, $bind_version);

# Sanity check: globals populated by lib.
is($bind_version, '9.18', 'bind_version normalized from version file');
ok($config{'named_conf'}, 'named_conf loaded from module config');

# --- IPv4 reverse helpers --------------------------------------------------
is(ip_to_arpa('1.2.3.4'), '4.3.2.1.in-addr.arpa.', 'ip_to_arpa basic');
is(arpa_to_ip('4.3.2.1.in-addr.arpa.'), '1.2.3.4', 'arpa_to_ip basic');
is(arpa_to_ip(ip_to_arpa('192.0.2.55')), '192.0.2.55',
   'ip_to_arpa round-trips through arpa_to_ip');
# Pass-through for non-matching input
is(arpa_to_ip('not.an.arpa.name'), 'not.an.arpa.name',
   'arpa_to_ip leaves non-arpa input alone');
is(ip_to_arpa('not.an.ip'), 'not.an.ip',
   'ip_to_arpa leaves non-IPv4 input alone');

# --- IPv6 helpers ----------------------------------------------------------
is(expand_ip6('2001:db8::1'), '2001:db8:0:0:0:0:0:1',
   'expand_ip6 expands ::');
is(expand_ip6('::1'), '0:0:0:0:0:0:0:1', 'expand_ip6 leading ::');
is(expand_ip6('fe80::'), 'fe80:0:0:0:0:0:0:0', 'expand_ip6 trailing ::');
is(expand_ip6('FE80::1'), 'fe80:0:0:0:0:0:0:1', 'expand_ip6 lowercases');
is(expandall_ip6('2001:db8::1'),
   '2001:0db8:0000:0000:0000:0000:0000:0001',
   'expandall_ip6 pads zeros');

# net_to_ip6int with default ipv6_mode=1 should produce ip6.arpa names
my $rev6 = net_to_ip6int('2001:db8::1');
like($rev6, qr/\.ip6\.arpa\.$/, 'net_to_ip6int returns ip6.arpa');
# Round-trip from ip6.arpa back to a canonical address
my $back = ip6int_to_net($rev6);
$back =~ s{/\d+$}{};
like($back, qr/^2001:.*::?1$/i,
     'ip6int_to_net inverts net_to_ip6int for full address');

# Bits parameter trims labels (and so encodes a /prefix length)
my $rev6_short = net_to_ip6int('2001:db8::', 32);
like($rev6_short, qr/^8\.b\.d\.0\.1\.0\.0\.2\.ip6\.arpa\.$/i,
     'net_to_ip6int with /32 truncates to 8 nibbles');

# --- email <-> dotted notation --------------------------------------------
is(email_to_dotted('admin@example.com'), 'admin.example.com.',
   'simple email -> dotted');
is(dotted_to_email('admin.example.com.'), 'admin@example.com',
   'simple dotted -> email');
is(dotted_to_email(email_to_dotted('hostmaster@example.com')),
   'hostmaster@example.com', 'email <-> dotted round-trip');
# Dots in local-part must be escaped, per RFC 1183
is(email_to_dotted('first.last@example.com'),
   'first\\.last.example.com.',
   'email_to_dotted escapes dots in local part');
is(dotted_to_email('first\\.last.example.com.'), 'first.last@example.com',
   'dotted_to_email unescapes dots in local part');
is(dotted_to_email('.'), '.', 'root domain dotted form preserved');

# --- valdnsname / valemail -------------------------------------------------
ok(valdnsname('host.example.com', 0), 'valid hostname accepted');
ok(valdnsname('_dmarc.example.com', 0, 'example.com', 'TXT'),
   'underscore allowed for TXT owner name');
ok(!valdnsname('_dmarc.example.com', 0, 'example.com', 'A'),
   'underscore rejected for A owner name when allow_underscore off');
ok(!valdnsname('-leading.example.com', 0),
   'leading dash rejected');
ok(!valdnsname('trailing-.example.com', 0),
   'trailing dash rejected');
ok(!valdnsname('a..b.example.com', 0),
   'double dot rejected');
ok(valdnsname('*.example.com', 1),
   'wildcard accepted when wild flag set');

ok(valemail('admin@example.com'), 'simple email valid');
ok(valemail('admin.test@example.com'), 'email with dot in local valid');
ok(valemail('.'), 'root marker email valid');
# valemail also accepts the SOA RNAME dotted form (no @), so "no-at-sign"
# parses successfully; the rejection cases are syntactically invalid input.
ok(!valemail('contains spaces'),
   'free-form text with spaces rejected');

# --- check_net_ip ----------------------------------------------------------
ok(check_net_ip('192.168.1.0/24'), 'CIDR /24 accepted');
ok(check_net_ip('192.168.1.5'), 'plain IP accepted');
ok(check_net_ip('10.0.1-100'), 'range syntax accepted');
ok(!check_net_ip('999.1.1.1'), 'out-of-range octet rejected');

# --- compute_serial --------------------------------------------------------
$config{'soa_style'} = 0;
is(compute_serial(2024010100), 2024010101,
   'soa_style 0 increments by one');
$config{'soa_style'} = 2;
my $now = time();
my $serial2 = compute_serial($now - 10);
ok($serial2 > $now - 10, 'soa_style 2 unix-time serial advances');
$config{'soa_style'} = 1;
$config{'soa_start'} = 0;
{
    # Pin date_serial() to a fixed value so a midnight rollover during the
    # test run can't desynchronize the "today" computed here from the one
    # computed inside compute_serial().
    my $today = '20260101';
    no warnings qw(redefine once);
    local *date_serial = sub { $today };
    my $serial1 = compute_serial($today.'00');
    is($serial1, $today.'01', 'soa_style 1 increments within day');
    # Rollover: same date, counter at 99 -> next day, counter resets to soa_start.
    my $rolled = compute_serial($today.'99');
    is($rolled, sprintf("%d%02d", $today + 1, 0),
       'soa_style 1 rolls counter past 99 to next day');
    # Older-dated serial gets bumped forward to today regardless.
    my $caught_up = compute_serial('1999010199');
    is($caught_up, $today.'00',
       'soa_style 1 catches up to current date when old serial is stale');
}

# --- make_record / record_id / find_record_by_id --------------------------
my $rec = make_record('www', 3600, 'IN', 'A', '192.0.2.1', 'web server');
like($rec, qr/^www\t3600\tIN\tA\t192\.0\.2\.1\t;web server$/,
     'make_record renders A record line');
my $rec_notlt = make_record('www', '', 'IN', 'A', '192.0.2.1');
is($rec_notlt, "www\tIN\tA\t192.0.2.1",
   'make_record omits TTL when blank');
# SPF gets mapped down to TXT when spf_record is 0 (default)
my $spfline = make_record('foo', '', 'IN', 'SPF', '"v=spf1 -all"');
like($spfline, qr/\tTXT\t/,
     'make_record maps SPF to TXT when spf_record=0');

my $r = { 'name' => 'a.example.com.', 'type' => 'A',
          'values' => [ '10.0.0.1' ] };
is(record_id($r), 'a.example.com./A/10.0.0.1', 'record_id basic');
my $soa = { 'name' => 'example.com.', 'type' => 'SOA',
            'values' => [ 'ns', 'admin', 1, 2, 3, 4, 5 ] };
is(record_id($soa), 'example.com./SOA',
   'record_id omits values for SOA');

my @recs = (
    { 'name' => 'a.example.com.', 'type' => 'A',
      'values' => [ '10.0.0.1' ], 'num' => 0 },
    { 'name' => 'a.example.com.', 'type' => 'A',
      'values' => [ '10.0.0.1' ], 'num' => 1 },
    { 'name' => 'b.example.com.', 'type' => 'A',
      'values' => [ '10.0.0.2' ], 'num' => 2 },
);
my $found = find_record_by_id(\@recs, 'b.example.com./A/10.0.0.2', 2);
ok($found && $found->{'num'} == 2, 'find_record_by_id unique match');
my $found_dup = find_record_by_id(\@recs, 'a.example.com./A/10.0.0.1', 1);
ok($found_dup && $found_dup->{'num'} == 1,
   'find_record_by_id picks correct duplicate by num');

# --- join_record_values ---------------------------------------------------
is(join_record_values({ 'type' => 'A', 'values' => [ '192.0.2.1' ] }),
   '192.0.2.1', 'join_record_values single A value');
is(join_record_values({ 'type' => 'TXT', 'values' => [ 'hello' ] }),
   '"hello"', 'join_record_values quotes TXT');
is(join_record_values({ 'type' => 'MX', 'values' => [ '10', 'mail.example.com.' ] }),
   '10 mail.example.com.', 'join_record_values MX preference and host');

# --- SPF parsing / serialization ------------------------------------------
my $spf = parse_spf('v=spf1 mx a:relay.example.com ip4:192.0.2.0/24 -all');
ok($spf, 'parse_spf returns hash');
is($spf->{'mx'}, 1, 'spf flag mx set');
is_deeply($spf->{'a:'}, [ 'relay.example.com' ], 'spf a: list');
is_deeply($spf->{'ip4:'}, [ '192.0.2.0/24' ], 'spf ip4: list');
is($spf->{'all'}, 3, 'spf -all maps to 3');
my $spf_str = join_spf($spf);
like($spf_str, qr/v=spf1/, 'join_spf starts with v=spf1');
like($spf_str, qr/-all/, 'join_spf preserves -all');
my $spf2 = parse_spf($spf_str);
is($spf2->{'all'}, 3, 'spf round-trips -all');
is_deeply($spf2->{'a:'}, [ 'relay.example.com' ], 'spf round-trips a:');
is_deeply($spf2->{'ip4:'}, [ '192.0.2.0/24' ], 'spf round-trips ip4:');

# Not an SPF record
is(parse_spf('just some text'), undef, 'parse_spf returns undef for non-SPF');

# --- DMARC parsing / serialization ----------------------------------------
my $dmarc = parse_dmarc('v=DMARC1; p=reject; rua=mailto:dmarc@example.com; pct=100');
ok($dmarc, 'parse_dmarc returns hash');
is($dmarc->{'p'}, 'reject', 'dmarc policy');
is($dmarc->{'pct'}, '100', 'dmarc pct');
is($dmarc->{'rua'}, 'mailto:dmarc@example.com', 'dmarc rua');
my $dmarc_str = join_dmarc($dmarc);
like($dmarc_str, qr/v=DMARC1/, 'join_dmarc starts with v=DMARC1');
like($dmarc_str, qr/p=reject/, 'join_dmarc preserves policy');
my $dmarc2 = parse_dmarc($dmarc_str);
is($dmarc2->{'p'}, 'reject', 'dmarc round-trips policy');
is($dmarc2->{'pct'}, '100', 'dmarc round-trips pct');

# --- extract_time_units ----------------------------------------------------
my @ev = ('3600', '5M', '2H', '1D', '7W');
my @units = extract_time_units(@ev);
is_deeply(\@units, ['', 'M', 'H', 'D', 'W'], 'extract_time_units returns units');
is_deeply(\@ev, ['3600', '5', '2', '1', '7'],
          'extract_time_units strips trailing unit char in place');

# --- version_atleast -------------------------------------------------------
ok(version_atleast(9), 'bind 9.18 is >= 9');
ok(version_atleast(9, 18), 'bind 9.18 is >= 9.18');
ok(!version_atleast(9, 19), 'bind 9.18 is not >= 9.19');

# --- wrap_lines / convert_to_absolute -------------------------------------
is_deeply([ wrap_lines('abcdefghij', 3) ],
          [ 'abc', 'def', 'ghi', 'j' ],
          'wrap_lines splits text');
is_deeply([ wrap_lines('', 5) ], [],
          'wrap_lines returns empty list for empty input');

is(convert_to_absolute('www', 'example.com'), 'www.example.com.',
   'convert_to_absolute short name');
is(convert_to_absolute('@', 'example.com'), 'example.com.',
   'convert_to_absolute @ name');
is(convert_to_absolute('www.example.com', 'example.com'),
   'www.example.com.', 'convert_to_absolute name already in zone');
is(convert_to_absolute('www.other.', 'example.com'), 'www.other.',
   'convert_to_absolute keeps fully qualified name');

# --- make_reverse_name ----------------------------------------------------
is(make_reverse_name('192.0.2.1', 'A', { 'name' => '2.0.192.in-addr.arpa' }),
   '1.2.0.192.in-addr.arpa.', 'make_reverse_name IPv4');
# Partial reverse delegation: zone name encodes a /27 inside a /24
my $partial = { 'name' => '0/27.2.0.192.in-addr.arpa' };
is(make_reverse_name('192.0.2.5', 'A', $partial),
   '5.0/27.2.0.192.in-addr.arpa.',
   'make_reverse_name partial reverse delegation');

# --- dnssec_size_range / list_dnssec_algorithms ---------------------------
is_deeply([ dnssec_size_range('RSASHA256') ], [ 2048, 4096 ],
          'dnssec_size_range RSASHA256');
is_deeply([ dnssec_size_range('DSA') ], [ 512, 1024, 64 ],
          'dnssec_size_range DSA includes divisor');
is_deeply([ dnssec_size_range('NOPE') ], [],
          'dnssec_size_range unknown alg returns empty');
my @algs = list_dnssec_algorithms();
ok((grep { $_ eq 'ED25519' } @algs),
   'list_dnssec_algorithms includes ED25519');

# --- can_edit_zone access control ------------------------------------------
{
    local %access = ( 'zones' => '*', 'inviews' => '*', 'dironly' => 0 );
    ok(can_edit_zone({ 'name' => 'example.com', 'file' => '/etc/named/example.com' }),
       'wildcard ACL allows any zone');

    %access = ( 'zones' => 'example.com', 'inviews' => '*' );
    ok(can_edit_zone({ 'name' => 'example.com' }),
       'allow-list ACL accepts named zone');
    ok(!can_edit_zone({ 'name' => 'other.com' }),
       'allow-list ACL rejects unlisted zone');

    # Deny-list convention: leading "!" is a separate token (see acl_security.pl).
    %access = ( 'zones' => '! banned.com', 'inviews' => '*' );
    ok(can_edit_zone({ 'name' => 'allowed.com' }),
       'deny-list ACL allows unbanned zone');
    ok(!can_edit_zone({ 'name' => 'banned.com' }),
       'deny-list ACL rejects banned zone');

    %access = ( 'zones' => '*', 'inviews' => 'internal' );
    ok(can_edit_zone({ 'name' => 'z.com', 'view' => 'internal' }),
       'view ACL accepts matching view');
    ok(!can_edit_zone({ 'name' => 'z.com', 'view' => 'external' }),
       'view ACL rejects mismatched view');
}

# --- can_edit_view ---------------------------------------------------------
{
    local %access = ( 'vlist' => '*' );
    ok(can_edit_view({ 'name' => 'anyview' }),
       'wildcard view ACL allows all');
    %access = ( 'vlist' => 'public private' );
    ok(can_edit_view({ 'name' => 'public' }),
       'allow-list view ACL accepts listed view');
    ok(!can_edit_view({ 'name' => 'hidden' }),
       'allow-list view ACL rejects unlisted view');
    %access = ( 'vlist' => '! hidden' );
    ok(can_edit_view({ 'name' => 'public' }),
       'deny-list view ACL allows non-listed view');
    ok(!can_edit_view({ 'name' => 'hidden' }),
       'deny-list view ACL rejects listed view');
}

# --- config-file parser round-trip ----------------------------------------
my $sample = <<'EOF';
// Test BIND config
options {
	directory "/var/named";
	listen-on port 53 { 127.0.0.1; 192.0.2.1; };
	allow-query { localhost; };
};

zone "example.com" IN {
	type master;
	file "example.com.hosts";
	allow-transfer { 192.0.2.2; };
};

zone "0.0.127.in-addr.arpa" {
	type master;
	file "named.local";
};
EOF
$config{'named_conf'} = $named_conf;
open(my $nfh, ">", $named_conf) or die "named.conf: $!";
print $nfh $sample;
close($nfh);
clear_config_cache();

my $conf = get_config();
ok(ref($conf) eq 'ARRAY' && @$conf >= 3,
   'read_config_file returned >= 3 top-level structures');

my ($opts) = find('options', $conf);
ok($opts && $opts->{'members'}, 'options block parsed');
my $dir = find_value('directory', $opts->{'members'});
is($dir, '/var/named', 'directory option value');

my ($lo) = find('listen-on', $opts->{'members'});
ok($lo, 'listen-on directive present');
is($lo->{'value'}, 'port', 'listen-on first value');
is_deeply($lo->{'values'}, [ 'port', '53' ],
          'listen-on values before block');
is(scalar @{$lo->{'members'}}, 2,
   'listen-on inner block has 2 addresses');

my @zones = find('zone', $conf);
is(scalar @zones, 2, 'two zone directives found');
my ($z) = grep { $_->{'value'} eq 'example.com' } @zones;
ok($z, 'example.com zone found');
is(find_value('type', $z->{'members'}), 'master',
   'example.com zone type');
is(find_value('file', $z->{'members'}), 'example.com.hosts',
   'example.com zone file');

# extract_value handles directives with no separate 'value'
my $no_value = { 'values' => [ 'first', 'second' ] };
is(extract_value($no_value), 'first',
   'extract_value falls back to first values entry');

# directive_lines renders a structure back to text that can be re-parsed
my @lines = directive_lines($z, 0);
ok(scalar @lines >= 1, 'directive_lines emits at least one line');
like($lines[0], qr/^zone "example\.com"/,
     'directive_lines quotes zone name');

# Write rendered config back out and verify it re-parses identically
my $named_conf2 = "$confdir/named-roundtrip.conf";
open(my $rfh, ">", $named_conf2) or die "rt: $!";
foreach my $top (@$conf) {
    print $rfh join("\n", directive_lines($top, 0)), "\n";
}
close($rfh);
my @reparsed = read_config_file($named_conf2);
my ($z2) = grep { $_->{'name'} eq 'zone' &&
                  $_->{'value'} eq 'example.com' } @reparsed;
ok($z2, 'example.com zone present after round-trip');
is(find_value('file', $z2->{'members'}), 'example.com.hosts',
   'example.com zone file survives round-trip');
my ($opts2) = grep { $_->{'name'} eq 'options' } @reparsed;
is(find_value('directory', $opts2->{'members'}), '/var/named',
   'options directory survives round-trip');

# --- zone-file parser ------------------------------------------------------
my $zonefile = "$confdir/example.com.hosts";
open(my $zfh, ">", $zonefile) or die "zonefile: $!";
print $zfh <<'EOF';
$TTL 3600
@	IN	SOA	ns1.example.com. hostmaster.example.com. (
				2024010101 ; serial
				3600 ; refresh
				600 ; retry
				1209600 ; expire
				3600 ) ; minimum
@	IN	NS	ns1.example.com.
@	IN	NS	ns2.example.com.
ns1	IN	A	192.0.2.1
ns2	IN	A	192.0.2.2
www	IN	CNAME	@
mail	IN	A	192.0.2.10
@	IN	MX	10 mail
_dmarc	IN	TXT	"v=DMARC1; p=none"
EOF
close($zfh);

my @zrecs = read_zone_file($zonefile, 'example.com', undef, 0, 1);
ok(scalar @zrecs >= 8, 'read_zone_file parsed multiple records')
    or diag("got ".scalar(@zrecs)." records");

my ($soa_rec) = grep { $_->{'type'} eq 'SOA' } @zrecs;
ok($soa_rec, 'SOA record parsed');
is(scalar @{$soa_rec->{'values'}}, 7,
   'SOA has mname rname and 5 numeric fields');
is($soa_rec->{'values'}->[2], '2024010101', 'SOA serial parsed');

my @ns = grep { $_->{'type'} eq 'NS' } @zrecs;
is(scalar @ns, 2, 'two NS records parsed');

my @a = grep { $_->{'type'} eq 'A' } @zrecs;
is(scalar @a, 3, 'three A records parsed');

my ($mx) = grep { $_->{'type'} eq 'MX' } @zrecs;
ok($mx, 'MX record parsed');
is_deeply($mx->{'values'}, [ '10', 'mail' ],
          'MX values: preference + host');

# DMARC underneath an underscore name: zone parser classifies as DMARC
my ($dmarc_rec) = grep { uc($_->{'type'}) eq 'DMARC' } @zrecs;
ok($dmarc_rec, 'DMARC record reclassified from TXT');

# --- only-soa fast path ----------------------------------------------------
my @soaonly = read_zone_file($zonefile, 'example.com', undef, 1, 1);
my @soas = grep { $_->{'type'} eq 'SOA' } @soaonly;
is(scalar @soas, 1, 'only-soa mode finds the SOA record');

# --- is_raw_format_records -------------------------------------------------
ok(!is_raw_format_records($zonefile),
   'text-format zone file not classified as raw');
my $rawfile = "$confdir/raw.zone";
open(my $rfh2, ">", $rawfile) or die "rawfile: $!";
binmode $rfh2;
print $rfh2 "\0\0\0xxx";
close($rfh2);
ok(is_raw_format_records($rawfile),
   'three-NUL preamble classified as raw format');

done_testing();