scripts/tests/network-diag.pl

#!/usr/bin/env perl
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
# SPDX-License-Identifier: MIT

# Checks for network-diag.pl: the address arithmetic, the address classification, the
# ping parsing, the MTU family fallback and the small helpers.
#
# Run from anywhere: perl tests/network-diag.pl

use strict;
use warnings;

my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
$root = "./$root" if $root !~ m{^/};
require "$root/network-diag.pl";

my ($passed, $failed) = (0, 0);

sub is {
    my ($got, $want, $label) = @_;
    $got = 'undef' unless defined $got;
    $want = 'undef' unless defined $want;
    if ($got eq $want) {
        $passed++;
        print "ok   $label\n";
        return 1;
    }
    $failed++;
    print "FAIL $label\n     got:  $got\n     want: $want\n";
    return 0;
}

sub check {
    my ($cond, $label) = @_;
    return is($cond ? 1 : 0, 1, $label);
}

sub hex_of {
    my ($bytes) = @_;
    return join(' ', map { sprintf('%02x', $_) } unpack('C*', $bytes));
}

# ---------------------------------------------------------------------------
# IPv4 and IPv6 parsing
# ---------------------------------------------------------------------------

is(hex_of(ip4_bytes('127.0.0.1')), '7f 00 00 01', 'ip4: 127.0.0.1');
is(hex_of(ip4_bytes('0.0.0.0')), '00 00 00 00', 'ip4: the unspecified address');
is(hex_of(ip4_bytes('255.255.255.255')), 'ff ff ff ff', 'ip4: the broadcast address');
is(ip4_bytes('256.0.0.1'), undef, 'ip4: an octet above 255 is refused');
is(ip4_bytes('1.2.3'), undef, 'ip4: three octets are refused');
is(ip4_bytes('1.2.3.4.5'), undef, 'ip4: five octets are refused');
is(ip4_bytes('::1'), undef, 'ip4: an IPv6 address is refused');

is(hex_of(ip6_bytes('::')), '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00',
    'ip6: the unspecified address');
is(hex_of(ip6_bytes('::1')), '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01',
    'ip6: loopback in shorthand');
is(hex_of(ip6_bytes('2001:db8::1')), '20 01 0d b8 00 00 00 00 00 00 00 00 00 00 00 01',
    'ip6: shorthand in the middle');
is(hex_of(ip6_bytes('::ffff:127.0.0.1')), '00 00 00 00 00 00 00 00 00 00 ff ff 7f 00 00 01',
    'ip6: an embedded IPv4 address');
is(hex_of(ip6_bytes('fe80::1%eth0')), 'fe 80 00 00 00 00 00 00 00 00 00 00 00 00 00 01',
    'ip6: a scope suffix is dropped');
is(hex_of(ip6_bytes('2001:0db8:0000:0000:0000:0000:0000:0001')),
    '20 01 0d b8 00 00 00 00 00 00 00 00 00 00 00 01', 'ip6: the full form');
is(ip6_bytes('127.0.0.1'), undef, 'ip6: an IPv4 address is refused');
is(ip6_bytes('2001:db8:::1'), undef, 'ip6: a malformed address is refused');
is(ip6_bytes('2001:db8::1::2'), undef, 'ip6: two shorthands are refused');

is(is_mapped6('::ffff:10.0.0.1'), 1, 'mapped: an IPv4-mapped address');
is(is_mapped6('::1'), 0, 'mapped: loopback is not mapped');
is(is_mapped6('2001:db8::1'), 0, 'mapped: a global address is not mapped');

# ---------------------------------------------------------------------------
# sockaddr packing
# ---------------------------------------------------------------------------

my $sa = sa_in('127.0.0.1', 80);
is(length($sa), 16, 'sa_in: a sockaddr_in is 16 bytes');
is(unpack('S', substr($sa, 0, 2)), 2, 'sa_in: the family is AF_INET');
is(unpack('n', substr($sa, 2, 2)), 80, 'sa_in: the port is network order');
is(hex_of(substr($sa, 4, 4)), '7f 00 00 01', 'sa_in: the address follows');
is(hex_of(substr($sa, 8)), '00 00 00 00 00 00 00 00', 'sa_in: the padding is zero');
is(sa_in('::1', 80), undef, 'sa_in: an IPv6 address is refused');

my $sa6 = sa_in6('::1', 443);
is(length($sa6), 28, 'sa_in6: a sockaddr_in6 is 28 bytes');
is(unpack('n', substr($sa6, 2, 2)), 443, 'sa_in6: the port is network order');
is(hex_of(substr($sa6, 8, 16)), '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 01',
    'sa_in6: the address follows the flow information');
is(sa_in6('127.0.0.1', 443), undef, 'sa_in6: an IPv4 address is refused');

# ---------------------------------------------------------------------------
# Address classification
# ---------------------------------------------------------------------------

is(class4(ip4_bytes('127.0.0.1')), 'loopback', 'class4: loopback');
is(class4(ip4_bytes('169.254.1.1')), 'linklocal', 'class4: link-local');
is(class4(ip4_bytes('0.0.0.0')), 'unspecified', 'class4: unspecified');
is(class4(ip4_bytes('224.0.0.1')), 'multicast', 'class4: multicast');
is(class4(ip4_bytes('10.0.0.1')), 'private', 'class4: the ten network');
is(class4(ip4_bytes('192.168.1.1')), 'private', 'class4: the 192.168 network');
is(class4(ip4_bytes('172.16.0.1')), 'private', 'class4: the 172.16 network');
is(class4(ip4_bytes('100.64.0.1')), 'private', 'class4: carrier-grade NAT');
is(class4(ip4_bytes('8.8.8.8')), 'global', 'class4: a global address');

is(class6(ip6_bytes('::')), 'unspecified', 'class6: unspecified');
is(class6(ip6_bytes('::1')), 'loopback', 'class6: loopback');
is(class6(ip6_bytes('::ffff:1.2.3.4')), 'mapped', 'class6: IPv4-mapped');
is(class6(ip6_bytes('fe80::1')), 'linklocal', 'class6: link-local');
is(class6(ip6_bytes('ff02::1')), 'multicast', 'class6: multicast');
is(class6(ip6_bytes('fd00::1')), 'private', 'class6: unique local');
is(class6(ip6_bytes('2002::1')), 'private', 'class6: 6to4');
is(class6(ip6_bytes('2001:db8::1')), 'global', 'class6: a documentation prefix');

is(address_kind('v4', '127.0.0.1'), 'loopback', 'address_kind: an IPv4 class');
is(address_kind('v6', '::1'), 'loopback', 'address_kind: an IPv6 class');
is(address_kind('v4', 'not-an-address'), '', 'address_kind: unparsable input is empty');

# ---------------------------------------------------------------------------
# Ping output
# ---------------------------------------------------------------------------

my $iputils = <<'PING';
PING cloudflare.com (104.16.132.229) 56(84) bytes of data.
64 bytes from 104.16.132.229: icmp_seq=1 ttl=57 time=11.2 ms
64 bytes from 104.16.132.229: icmp_seq=2 ttl=57 time=12.4 ms
64 bytes from 104.16.132.229: icmp_seq=3 ttl=57 time=10.1 ms

--- cloudflare.com ping statistics ---
3 packets transmitted, 3 received, 0% packet loss, time 2003ms
rtt min/avg/max/mdev = 10.109/11.233/12.401/0.938 ms
PING

my ($latencies, $received) = parse_ping_output($iputils);
is(scalar(@$latencies), 3, 'ping: three replies are parsed');
is($latencies->[0], '11.2', 'ping: the first latency');
is($latencies->[2], '10.1', 'ping: the last latency');
is($received, 3, 'ping: the received counter');

my $lossy = <<'PING';
2 packets transmitted, 1 received, 50% packet loss, time 1001ms
PING
my ($none, $one) = parse_ping_output($lossy);
is(scalar(@$none), 0, 'ping: a transcript without replies has no latencies');
is($one, 1, 'ping: a partial loss is counted');

my ($min, $max, $sum) = min_max_sum([3, 1, 2]);
is($min, 1, 'latency: the minimum');
is($max, 3, 'latency: the maximum');
is($sum, 6, 'latency: the sum');

# ---------------------------------------------------------------------------
# Listening sockets
# ---------------------------------------------------------------------------

my @ss_ports = parse_ss_output(
    "State  Recv-Q  Send-Q  Local Address:Port  Peer Address:Port  Process\n" .
    "LISTEN  0       128     0.0.0.0:22          0.0.0.0:*          users:((\"sshd daemon\",pid=977,fd=3))\n" .
    "LISTEN  0       128     [::]:22             [::]:*\n"
);
is($ss_ports[0]{process}, 'users:(("sshd daemon",pid=977,fd=3))',
    'ss: a process name with spaces is kept whole');
is($ss_ports[0]{bucket}, 'tcp4', 'ss: a plain local address is IPv4');
is($ss_ports[1]{process}, '', 'ss: a socket without permission has no process');
is($ss_ports[1]{bucket}, 'tcp6', 'ss: a bracketed local address is IPv6');

# ---------------------------------------------------------------------------
# Grading
# ---------------------------------------------------------------------------

is(grade_letter(100), 'A', 'grade: a perfect score');
is(grade_letter(90), 'A', 'grade: the A boundary');
is(grade_letter(89.9), 'B', 'grade: just under the A boundary');
is(grade_letter(80), 'B', 'grade: the B boundary');
is(grade_letter(70), 'C', 'grade: the C boundary');
is(grade_letter(60), 'D', 'grade: the D boundary');
is(grade_letter(59.9), 'F', 'grade: just under the D boundary');
is(grade_letter(0), 'F', 'grade: zero');

my $graded = compute_grade({});
is(ref($graded), 'HASH', 'grade: the verdict is a hash');
is($graded->{score}, 0, 'grade: no data scores zero');
is($graded->{grade}, 'F', 'grade: no data fails');
check($graded->{max_score} > 0, 'grade: the maximum is reported');
check(ref($graded->{breakdown}) eq 'HASH', 'grade: the breakdown is a hash');
my $full = compute_grade({
    ping => { loss_pct => 0, avg_ms => 10 },
    dns  => { v4 => { 'example.org' => [{ ms => 5 }] } },
});
check($full->{score} >= 0 && $full->{score} <= $full->{max_score},
    'grade: a measured run stays within the maximum');

is(ms_colour(undef), "\033[2m", 'colour: an unmeasured latency is dim');
is(ms_colour(0), "\033[2m", 'colour: a zero latency is dim');
check(ms_colour(5) ne ms_colour(5000), 'colour: the bands differ');

# ---------------------------------------------------------------------------
# Serialisation and arguments
# ---------------------------------------------------------------------------

is(perl_literal(5), '5', 'literal: an integer stays bare');
is(perl_literal(1.5), '1.5', 'literal: a float stays bare');
is(perl_literal('abc'), "'abc'", 'literal: a word is quoted');
is(perl_literal('42x'), "'42x'", 'literal: a number-like word is quoted');
is(perl_literal(undef), 'undef', 'literal: undef');
is(perl_literal("it's"), "'it\\'s'", 'literal: a quote is escaped');
is(perl_literal([1, 2]), '[1, 2]', 'literal: an array');
is(perl_literal({ b => 2, a => 1 }), "{ 'a' => 1, 'b' => 2 }", 'literal: a hash in key order');

eval { write_literal('/nonexistent/network-diag-check', 1) };
check(scalar($@ =~ /cannot write /), 'result write: a failed write names the operation');

{
    local $ENV{TMPDIR} = '';
    my $scratch = eval { scratch_dir() };
    check(defined($scratch) && index($scratch // '', '/tmp/') == 0,
        'scratch: an empty TMPDIR falls back to /tmp');
    remove_scratch() if defined $scratch;
}

my $report_out = '';
open(my $report_cap, '>', \$report_out) or die "cannot capture the report: $!\n";
{
    local *STDOUT = $report_cap;
    print_report({ hostname => 'testhost', os => 'linux', dns => { error => 'probe boom' } });
}
close($report_cap);
check(index($report_out, 'unavailable: probe boom') >= 0,
    'report: a failed DNS check names its error');

my @saved = @ARGV;
@ARGV = ('--target', 'example.org', '--protocol', 'v6');
my %args = parse_args();
is($args{target}, 'example.org', 'args: --target takes a value');
is($args{protocol}, 'v6', 'args: --protocol takes a value');
@ARGV = @saved;

@ARGV = ();
my %defaults = parse_args();
is($defaults{protocol}, 'auto', 'args: the family defaults to auto');
is($defaults{target}, 'cloudflare.com', 'args: the target has a default');
@ARGV = @saved;

# ---------------------------------------------------------------------------
# The MTU probe, through fixture binaries on a private PATH
# ---------------------------------------------------------------------------

# A fake getent answers the resolver probe and one fixed name, and a fake ping
# models a host whose IPv6 path is dead while IPv4 passes a 1500 B DF probe.
# Together they exercise the family fallback of check_mtu end to end without
# touching the network.
sub install_fake_bin {
    my ($dir, $name, $body) = @_;
    open(my $fh, '>', "$dir/$name") or die "cannot write $dir/$name: $!\n";
    print {$fh} "#!/usr/bin/env perl\n", $body;
    close($fh);
    chmod(0755, "$dir/$name") or die "cannot chmod $dir/$name: $!\n";
    return;
}

my $bindir = "/tmp/network-diag-test-bin.$$";
mkdir($bindir, 0700) or die "cannot create $bindir: $!\n";

{
    local $ENV{PATH} = "$bindir:$ENV{PATH}";

    install_fake_bin($bindir, 'getent', <<'FIXTURE');
my ($verb, $host) = @ARGV;
if ($verb eq 'ahostsv4' && $host eq 'localhost') {
    print "127.0.0.1        STREAM\n";
    print "# the localhost resolver probe\n";
    exit 0;
}
if ($host eq 'mtu-fallback.test') {
    print $verb eq 'ahostsv6' ? "2001:db8::1     STREAM\n" : "192.0.2.10      STREAM\n";
    exit 0;
}
exit 2;
FIXTURE

    install_fake_bin($bindir, 'ping', <<'FIXTURE');
my ($family, $payload) = ('', 0);
for (my $i = 0; $i < @ARGV; $i++) {
    $family = $ARGV[$i] if $ARGV[$i] eq '-4' || $ARGV[$i] eq '-6';
    $payload = $ARGV[$i + 1] if $ARGV[$i] eq '-s';
}
if ($family eq '-6' || $payload > 1472) {
    print "1 packets transmitted, 0 received, 100% packet loss, time 0ms\n";
    exit 1;
}
print "1 packets transmitted, 1 received, 0% packet loss, time 0ms\n";
exit 0;
FIXTURE

    my $auto = check_mtu('mtu-fallback.test', 'auto', 'linux');
    is($auto->{path_mtu}, 1500, 'mtu: a dead preferred family falls back to the other');
    check(index($auto->{method} // '', 'IPv4 fallback') >= 0,
        'mtu: the fallback names the family that answered');

    my $v6 = check_mtu('mtu-fallback.test', 'v6', 'linux');
    is($v6->{path_mtu}, 0, 'mtu: an explicit protocol choice does not fall back');
    is($v6->{method}, 'ping DF probe (no probe size succeeded)',
        'mtu: an explicit protocol choice reports the failure');

    my $v4 = check_mtu('mtu-fallback.test', 'v4', 'linux');
    is($v4->{path_mtu}, 1500, 'mtu: the preferred family answering needs no fallback');
    is($v4->{method}, 'ping DF probe (1500B OK)', 'mtu: a direct hit carries no fallback note');
}

unlink(glob("$bindir/*"));
rmdir($bindir) or die "cannot remove $bindir: $!\n";

print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
exit($failed ? 1 : 0);