317 lines
14 KiB
Perl
317 lines
14 KiB
Perl
#!/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);
|