1585 lines
56 KiB
Perl
1585 lines
56 KiB
Perl
#!/usr/bin/env perl
|
||
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||
# SPDX-License-Identifier: MIT
|
||
|
||
# Network diagnostics: latency, DNS, MTU, packet loss, dual-stack and port checks.
|
||
#
|
||
# Perl builtins only. No module is required to run this. The two capabilities
|
||
# that Perl no longer exposes as builtins are handled the way the rules prescribe:
|
||
#
|
||
# * Address arithmetic (inet_aton and its relatives moved into Socket) is
|
||
# hand-rolled below, in ip4_bytes and ip6_bytes.
|
||
# * Name resolution, sockets aside, is delegated to a system binary that speaks
|
||
# getaddrinfo, which keeps /etc/hosts, nsswitch and any caching resolver in the
|
||
# picture. getent is preferred and host, present in the FreeBSD base system and
|
||
# shipped with bind-utils on Linux, is the fallback. Which one is in use is
|
||
# probed at run time rather than assumed.
|
||
#
|
||
# One capability has no builtin substitute at all: a monotonic clock with
|
||
# millisecond resolution, which the TCP and DNS latency figures are measured with.
|
||
# Time::HiRes is therefore loaded opportunistically inside eval and never assumed.
|
||
# The measurement behind that caution: on Fedora, perl-Time-HiRes is its own RPM
|
||
# and is not among the requirements of perl-interpreter, so a bare perl need not
|
||
# have it. Where it is absent the report says the figure was not measured and the
|
||
# grade drops that component rather than inventing a number.
|
||
#
|
||
# External binaries used: ping, ip, ifconfig, netstat, ss, sockstat, sudo, getent
|
||
# or host, and uname.
|
||
#
|
||
# Linux and FreeBSD are supported in their current releases, with no branch for a
|
||
# superseded one: the unified ping that understands -4 and -6 is the only one
|
||
# driven here.
|
||
#
|
||
# Usage:
|
||
# network-diag.pl # full diagnostic
|
||
# network-diag.pl --target cloudflare.com # target a specific host
|
||
# network-diag.pl --protocol v4 # IPv4 only
|
||
# network-diag.pl --protocol v6 # IPv6 only
|
||
|
||
use strict;
|
||
use warnings;
|
||
|
||
my $VERSION = '2.0.0';
|
||
|
||
my $BOLD = "\033[1m";
|
||
my $RED = "\033[31m";
|
||
my $GREEN = "\033[32m";
|
||
my $YELLOW = "\033[33m";
|
||
my $DIM = "\033[2m";
|
||
my $RESET = "\033[0m";
|
||
|
||
# Well-known hosts for the connectivity tests, in report order.
|
||
my @CONNECTIVITY_HOSTS = (['cloudflare.com', 443], ['google.com', 443]);
|
||
|
||
# The optional clock. Loaded here, once, and guarded everywhere it is used.
|
||
my $HAVE_HIRES = eval { require Time::HiRes; 1 } ? 1 : 0;
|
||
|
||
# Socket constants. AF_INET6 is 10 on Linux and 28 on FreeBSD, the only two
|
||
# platforms this script supports; the other values are the same on both.
|
||
sub af_inet6 { return $^O eq 'freebsd' ? 28 : 10 }
|
||
my $AF_INET = 2;
|
||
my $SOCK_STREAM = 1;
|
||
my $IPPROTO_TCP = 6;
|
||
|
||
# Address families as the user names them.
|
||
my $FAMILY_LABEL = { v4 => 'IPv4', v6 => 'IPv6' };
|
||
|
||
my $TMP_DIR; # private scratch directory, created only when needed
|
||
my $PARENT_PID = $$; # forked children must never clean up for the parent
|
||
my $RESOLVER; # cached resolver transport: 'getent', 'host' or ''
|
||
my $RESOLVER_OVERHEAD; # measured start-up cost of that transport, in ms
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Small helpers
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# Monotonic milliseconds source. Returns undef when no clock is available, and
|
||
# every caller then reports the figure as not measured instead of guessing.
|
||
sub now {
|
||
return $HAVE_HIRES ? Time::HiRes::time() : undef;
|
||
}
|
||
|
||
# One decimal place, as the report prints it.
|
||
sub round1 {
|
||
my ($value) = @_;
|
||
return sprintf('%.1f', $value);
|
||
}
|
||
|
||
sub detect_os {
|
||
return $^O eq 'freebsd' ? 'freebsd' : 'linux';
|
||
}
|
||
|
||
sub status {
|
||
my ($msg) = @_;
|
||
print STDERR " $msg...";
|
||
}
|
||
|
||
sub status_done {
|
||
my ($msg) = @_;
|
||
$msg = 'done' unless defined $msg;
|
||
print STDERR " $msg\n";
|
||
}
|
||
|
||
# A hand-rolled which(1): the system command is the transport, so the lookup
|
||
# itself must not need one.
|
||
sub find_exe {
|
||
my ($name) = @_;
|
||
return undef unless defined $name && length $name;
|
||
if (index($name, '/') >= 0) {
|
||
return (-f $name && -x _) ? $name : undef;
|
||
}
|
||
for my $dir (split /:/, ($ENV{PATH} // '')) {
|
||
next unless length $dir;
|
||
my $path = "$dir/$name";
|
||
return $path if -f $path && -x _;
|
||
}
|
||
return undef;
|
||
}
|
||
|
||
# Run a command, capturing stdout and stderr merged, with a timeout.
|
||
#
|
||
# The child is forked rather than opened as a pipe because the two streams have to
|
||
# be merged and a wedged process has to be killable, which the builtin pipe forms
|
||
# do not offer. The locale is forced to C because iputils translates its own
|
||
# output (under a Czech locale "time=" becomes "cas=" and the statistics line stops
|
||
# saying "transmitted"), and the whole report parses English. Returns the output
|
||
# and a status: 'ok', 'timeout' when the wait expired, or 'notfound' when the
|
||
# binary is missing, so callers can tell "tool unavailable" from "no output".
|
||
sub run {
|
||
my ($cmd, $timeout) = @_;
|
||
$timeout = 15 unless defined $timeout;
|
||
|
||
my $exe = find_exe($cmd->[0]);
|
||
return ('', 'notfound') unless defined $exe;
|
||
|
||
my ($rd, $wr);
|
||
pipe($rd, $wr) or die "cannot create a pipe: $!\n";
|
||
my $pid = fork();
|
||
die "cannot fork: $!\n" unless defined $pid;
|
||
|
||
if ($pid == 0) {
|
||
close($rd);
|
||
open(STDOUT, '>&', $wr) or exit 127;
|
||
open(STDERR, '>&', $wr) or exit 127;
|
||
close($wr);
|
||
$ENV{LANG} = 'C';
|
||
$ENV{LC_ALL} = 'C';
|
||
exec { $exe } @$cmd;
|
||
exit 127; # reached only when exec itself fails
|
||
}
|
||
|
||
close($wr);
|
||
my $out = '';
|
||
my $timed_out = 0;
|
||
eval {
|
||
local $SIG{ALRM} = sub { die "alarm\n" };
|
||
alarm($timeout);
|
||
local $/ = undef;
|
||
$out = <$rd>;
|
||
alarm(0);
|
||
1;
|
||
} or do { $timed_out = 1; alarm(0) };
|
||
$out = '' unless defined $out;
|
||
close($rd);
|
||
|
||
# Terminate the child, then reap it. A Term-ed process that ignores the
|
||
# signal is followed by a KILL, so the wait below cannot hang.
|
||
kill('TERM', $pid);
|
||
select(undef, undef, undef, 0.1);
|
||
kill('KILL', $pid);
|
||
waitpid($pid, 0);
|
||
my $exit_code = $? >> 8;
|
||
|
||
return ('', 'timeout') if $timed_out;
|
||
return ($out, 'notfound') if $exit_code == 127;
|
||
return ($out, 'ok');
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# ICMP latency
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# Per-reply latencies and the received counter, which differ between iputils and
|
||
# FreeBSD: "5 packets transmitted, 5 received" against "5 packets transmitted,
|
||
# 5 packets received". The counter is undef when no statistics line was seen, and
|
||
# callers then fall back to the number of parsed replies.
|
||
sub parse_ping_output {
|
||
my ($output) = @_;
|
||
my @latencies = $output =~ /time=(\d+(?:\.\d+)?)/g;
|
||
my $received;
|
||
for my $line (split /\n/, $output, -1) {
|
||
next unless index($line, 'transmitted') >= 0;
|
||
$received = $1 if $line =~ /(\d+)\s+(?:packets?\s+)?received/;
|
||
last;
|
||
}
|
||
return (\@latencies, $received);
|
||
}
|
||
|
||
sub min_max_sum {
|
||
my ($values) = @_;
|
||
my ($min, $max, $sum) = ($values->[0], $values->[0], 0);
|
||
for my $v (@$values) {
|
||
$min = $v if $v < $min;
|
||
$max = $v if $v > $max;
|
||
$sum += $v;
|
||
}
|
||
return ($min, $max, $sum);
|
||
}
|
||
|
||
# A standardised ping result. loss_pct comes from the received counter rather
|
||
# than from the number of parsed replies, which is the authoritative figure.
|
||
sub ping_result {
|
||
my ($host, $latencies, $received, $count, $protocol) = @_;
|
||
my $loss = $count > 0 ? round1(($count - $received) / $count * 100) : '100.0';
|
||
my %result = (
|
||
host => $host,
|
||
protocol => $protocol,
|
||
sent => $count,
|
||
received => $received,
|
||
loss_pct => $loss,
|
||
min_ms => '0.0',
|
||
avg_ms => '0.0',
|
||
max_ms => '0.0',
|
||
stddev_ms => '0.0',
|
||
);
|
||
if (@$latencies) {
|
||
my ($min, $max, $sum) = min_max_sum($latencies);
|
||
my $n = scalar @$latencies;
|
||
$result{min_ms} = round1($min);
|
||
$result{avg_ms} = round1($sum / $n);
|
||
$result{max_ms} = round1($max);
|
||
if ($n > 1) {
|
||
my $mean = $sum / $n;
|
||
my $sq = 0;
|
||
$sq += ($_ - $mean) ** 2 for @$latencies;
|
||
$result{stddev_ms} = round1(sqrt($sq / ($n - 1)));
|
||
}
|
||
}
|
||
return \%result;
|
||
}
|
||
|
||
# The ping command for an address family. Every supported release ships the
|
||
# unified ping that understands -4 and -6, so there is nothing to choose between.
|
||
sub ping_base_cmd {
|
||
my ($family) = @_;
|
||
return ['ping', ($family eq 'v6' ? '-6' : '-4')];
|
||
}
|
||
|
||
# Per-reply wait flag: iputils -W takes seconds, and FreeBSD ping -W takes
|
||
# milliseconds, which is the one difference between the two.
|
||
sub ping_wait_args {
|
||
my ($os_type, $timeout) = @_;
|
||
return $os_type eq 'freebsd' ? ['-W', $timeout * 1000] : ['-W', $timeout];
|
||
}
|
||
|
||
sub ping_host {
|
||
my ($host, $os_type, %opt) = @_;
|
||
my $count = $opt{count} // 5;
|
||
my $timeout = $opt{timeout} // 5;
|
||
my $protocol = $opt{protocol} // 'v4';
|
||
|
||
my $base = ping_base_cmd($protocol);
|
||
my @cmd = (@$base, '-c', $count, @{ping_wait_args($os_type, $timeout)}, '--', $host);
|
||
# The timeout must also cover the resolution ping does itself.
|
||
my ($out, $run_status) = run(\@cmd, $count + $timeout + 10);
|
||
if ($run_status eq 'notfound') {
|
||
my $result = ping_result($host, [], 0, $count, $protocol);
|
||
$result->{note} = "'$base->[0]' not found";
|
||
return $result;
|
||
}
|
||
|
||
my ($latencies, $parsed_received) = parse_ping_output($out);
|
||
my $received = defined $parsed_received ? $parsed_received : scalar @$latencies;
|
||
return ping_result($host, $latencies, $received, $count, $protocol);
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Address arithmetic, hand-rolled because Socket no longer shares it
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# Dotted quad to four bytes, or undef when it is not a dotted quad.
|
||
sub ip4_bytes {
|
||
my ($ip) = @_;
|
||
my @octets = split /\./, $ip, -1;
|
||
return undef unless @octets == 4;
|
||
for my $octet (@octets) {
|
||
return undef unless $octet =~ /^\d{1,3}$/ && $octet <= 255;
|
||
}
|
||
return pack('C4', @octets);
|
||
}
|
||
|
||
# Textual IPv6 to sixteen bytes, or undef. Handles the :: shorthand and a
|
||
# trailing embedded IPv4 form, and ignores a zone suffix.
|
||
sub ip6_bytes {
|
||
my ($ip) = @_;
|
||
$ip =~ s/%.*//;
|
||
return undef unless $ip =~ /^[0-9a-fA-F:.]+$/ && index($ip, ':') >= 0;
|
||
|
||
my ($head, $tail) = ($ip, '');
|
||
my $shorthand = 0;
|
||
if (index($ip, '::') >= 0) {
|
||
($head, $tail) = split /::/, $ip, 2;
|
||
$shorthand = 1;
|
||
}
|
||
my @head = length($head // '') ? split(/:/, $head, -1) : ();
|
||
my @tail = length($tail // '') ? split(/:/, $tail, -1) : ();
|
||
if (@tail && $tail[-1] =~ /\./) {
|
||
my $quad = ip4_bytes(pop @tail);
|
||
return undef unless defined $quad;
|
||
my @words = unpack('n2', $quad);
|
||
push @tail, sprintf('%x', $words[0]), sprintf('%x', $words[1]);
|
||
}
|
||
return undef if @head + @tail > ($shorthand ? 7 : 8);
|
||
|
||
my @groups = $shorthand ? (@head, (0) x (8 - @head - @tail), @tail) : (@head, @tail);
|
||
return undef unless @groups == 8;
|
||
for my $group (@groups) {
|
||
return undef unless $group =~ /^[0-9a-fA-F]{1,4}$/;
|
||
}
|
||
return pack('n8', map { hex } @groups);
|
||
}
|
||
|
||
# Is this textual address an IPv4-mapped IPv6 one (::ffff:a.b.c.d)? glibc's
|
||
# ahostsv6 answers with a mapped address for a name that has no AAAA record, and
|
||
# connecting to it silently uses IPv4, so it must never be taken for IPv6.
|
||
sub is_mapped6 {
|
||
my ($addr) = @_;
|
||
my $bytes = ip6_bytes($addr);
|
||
return 0 unless defined $bytes;
|
||
# Twelve bytes: ten of zero, then the 0xffff marker.
|
||
return substr($bytes, 0, 12) eq ("\0" x 10) . "\xff\xff" ? 1 : 0;
|
||
}
|
||
|
||
# sockaddr_in and sockaddr_in6, packed by hand. Linux has a two-byte sin_family
|
||
# and no length field; FreeBSD has sin_len first and a one-byte family.
|
||
sub sa_in {
|
||
my ($ip, $port) = @_;
|
||
my $bytes = ip4_bytes($ip);
|
||
return undef unless defined $bytes;
|
||
return pack('S n a4 x8', $AF_INET, $port, $bytes);
|
||
}
|
||
|
||
sub sa_in6 {
|
||
my ($ip, $port) = @_;
|
||
my $bytes = ip6_bytes($ip);
|
||
return undef unless defined $bytes;
|
||
return $^O eq 'freebsd'
|
||
? pack('C C n N a16 N', 28, 28, $port, 0, $bytes, 0)
|
||
: pack('S n N a16 N', 10, $port, 0, $bytes, 0);
|
||
}
|
||
|
||
# Address classification, approximating the IANA tables: 'global' is what the
|
||
# report calls a globally scoped
|
||
# address, 'private' everything else that is still usable, and the remaining
|
||
# kinds are excluded from consideration entirely.
|
||
sub class4 {
|
||
my ($bytes) = @_;
|
||
my @o = unpack('C4', $bytes);
|
||
return 'loopback' if $o[0] == 127;
|
||
return 'linklocal' if $o[0] == 169 && $o[1] == 254;
|
||
return 'unspecified' if $o[0] == 0;
|
||
return 'multicast' if $o[0] >= 224 && $o[0] <= 239;
|
||
return 'private' if $o[0] >= 240;
|
||
return 'private' if $o[0] == 10;
|
||
return 'private' if $o[0] == 172 && $o[1] >= 16 && $o[1] <= 31;
|
||
return 'private' if $o[0] == 192 && $o[1] == 168;
|
||
return 'private' if $o[0] == 100 && $o[1] >= 64 && $o[1] <= 127;
|
||
return 'private' if $o[0] == 192 && $o[1] == 0 && $o[2] == 0;
|
||
return 'private' if $o[0] == 192 && $o[1] == 0 && $o[2] == 2;
|
||
return 'private' if $o[0] == 192 && $o[1] == 88 && $o[2] == 99;
|
||
return 'private' if $o[0] == 198 && ($o[1] == 18 || $o[1] == 19);
|
||
return 'private' if $o[0] == 198 && $o[1] == 51 && $o[2] == 100;
|
||
return 'private' if $o[0] == 203 && $o[1] == 0 && $o[2] == 113;
|
||
return 'global';
|
||
}
|
||
|
||
sub class6 {
|
||
my ($bytes) = @_;
|
||
my @w = unpack('n8', $bytes);
|
||
return 'unspecified' if !grep { $_ } @w;
|
||
# The parentheses matter: without them the && joins grep's list and the
|
||
# condition collapses, which reported other addresses as loopback.
|
||
return 'loopback' if !(grep { $_ } @w[0 .. 6]) && $w[7] == 1;
|
||
return 'mapped' if !(grep { $_ } @w[0 .. 4]) && $w[5] == 0xffff;
|
||
return 'linklocal' if ($w[0] & 0xffc0) == 0xfe80;
|
||
return 'multicast' if ($w[0] & 0xff00) == 0xff00;
|
||
return 'private' if ($w[0] & 0xfe00) == 0xfc00; # unique local
|
||
return 'private' if $w[0] == 0x2002; # 6to4
|
||
return 'private' if $w[0] == 0x2001 && $w[1] == 0x0000; # Teredo
|
||
return 'global';
|
||
}
|
||
|
||
# Usable addresses of one family from the collected interface data, globally
|
||
# scoped ones first. Loopback, link-local, unspecified and multicast addresses
|
||
# are dropped.
|
||
sub family_addresses {
|
||
my ($iface_info, $family) = @_;
|
||
my (@global, @other);
|
||
for my $iface (@{ $iface_info->{interfaces} // [] }) {
|
||
for my $raw (@{ $iface->{ips} // [] }) {
|
||
my $addr = $raw;
|
||
$addr =~ s{/.*$}{};
|
||
my $kind;
|
||
if ($family eq 'v6') {
|
||
next unless index($addr, ':') >= 0;
|
||
my $bytes = ip6_bytes($addr);
|
||
next unless defined $bytes;
|
||
$kind = class6($bytes);
|
||
next if $kind eq 'loopback' || $kind eq 'linklocal'
|
||
|| $kind eq 'unspecified' || $kind eq 'multicast';
|
||
}
|
||
else {
|
||
next if index($addr, ':') >= 0;
|
||
my $bytes = ip4_bytes($addr);
|
||
next unless defined $bytes;
|
||
$kind = class4($bytes);
|
||
next if $kind eq 'loopback' || $kind eq 'linklocal'
|
||
|| $kind eq 'unspecified' || $kind eq 'multicast';
|
||
}
|
||
push @{ $kind eq 'global' ? \@global : \@other }, $addr;
|
||
}
|
||
}
|
||
return (@global, @other);
|
||
}
|
||
|
||
sub address_kind {
|
||
my ($family, $addr) = @_;
|
||
my $bytes = $family eq 'v6' ? ip6_bytes($addr) : ip4_bytes($addr);
|
||
return '' unless defined $bytes;
|
||
return $family eq 'v6' ? class6($bytes) : class4($bytes);
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Interfaces
|
||
# ---------------------------------------------------------------------------
|
||
|
||
sub interface_info {
|
||
my ($os_type) = @_;
|
||
my %info = (
|
||
interfaces => [],
|
||
default_route_v4 => '',
|
||
default_route_v6 => '',
|
||
error => '',
|
||
);
|
||
return interface_info_freebsd(\%info) if $os_type eq 'freebsd';
|
||
return interface_info_linux(\%info);
|
||
}
|
||
|
||
sub interface_info_linux {
|
||
my ($info) = @_;
|
||
my ($out, $run_status) = run(['ip', '-br', 'addr', 'show']);
|
||
if ($run_status eq 'notfound') {
|
||
$info->{error} = "'ip' not found";
|
||
return $info;
|
||
}
|
||
for my $line (split /\n/, $out, -1) {
|
||
my @parts = split ' ', $line;
|
||
next if @parts < 2 || $parts[0] eq 'lo';
|
||
push @{ $info->{interfaces} }, {
|
||
name => $parts[0],
|
||
state => $parts[1],
|
||
ips => [ @parts[2 .. $#parts] ],
|
||
};
|
||
}
|
||
|
||
for my $item (['-4', 'default_route_v4'], ['-6', 'default_route_v6']) {
|
||
my ($family_flag, $key) = @$item;
|
||
my ($route, $route_status) = run(['ip', $family_flag, 'route', 'show', 'default']);
|
||
next unless $route_status eq 'ok';
|
||
my @parts = split ' ', $route;
|
||
for my $i (0 .. $#parts) {
|
||
next unless $parts[$i] eq 'via' && $i + 1 <= $#parts;
|
||
$info->{$key} = $parts[$i + 1];
|
||
last;
|
||
}
|
||
}
|
||
return $info;
|
||
}
|
||
|
||
sub interface_info_freebsd {
|
||
my ($info) = @_;
|
||
my ($iflist, $list_status) = run(['ifconfig', '-l']);
|
||
if ($list_status eq 'notfound') {
|
||
$info->{error} = "'ifconfig' not found";
|
||
return $info;
|
||
}
|
||
my @names = split ' ', $iflist;
|
||
return $info unless @names;
|
||
|
||
for my $name (@names) {
|
||
next if $name eq 'lo0';
|
||
my ($out, $run_status) = run(['ifconfig', $name]);
|
||
next unless $run_status eq 'ok';
|
||
my @lines = split /\n/, $out, -1;
|
||
next unless @lines && length $lines[0];
|
||
|
||
my $state = (index($lines[0], '<UP,') >= 0 || index($lines[0], '<UP>') >= 0)
|
||
? 'UP' : 'DOWN';
|
||
|
||
my @ips;
|
||
for my $line (@lines[1 .. $#lines]) {
|
||
my $stripped = $line;
|
||
$stripped =~ s/^\s+//;
|
||
$stripped =~ s/\s+$//;
|
||
if ($stripped =~ /^inet /) {
|
||
my @parts = split ' ', $stripped;
|
||
push @ips, $parts[1] if @parts >= 2 && $parts[1] ne '127.0.0.1';
|
||
}
|
||
elsif ($stripped =~ /^inet6 /) {
|
||
my @parts = split ' ', $stripped;
|
||
next if @parts < 2;
|
||
my $addr = $parts[1];
|
||
$addr =~ s/%.*//;
|
||
next if $addr =~ /^fe80:/ || $addr eq '::1';
|
||
push @ips, $addr;
|
||
}
|
||
}
|
||
push @{ $info->{interfaces} }, { name => $name, state => $state, ips => \@ips };
|
||
}
|
||
|
||
my ($route, $route_status) = run(['netstat', '-rn']);
|
||
return $info unless $route_status eq 'ok';
|
||
for my $line (split /\n/, $route, -1) {
|
||
next unless $line =~ /^default/;
|
||
my @parts = split ' ', $line;
|
||
next if @parts < 2;
|
||
my $gateway = $parts[1];
|
||
$gateway =~ s/%.*//;
|
||
if (index($gateway, ':') >= 0) {
|
||
$info->{default_route_v6} = $gateway unless $info->{default_route_v6};
|
||
}
|
||
elsif (!$info->{default_route_v4}) {
|
||
$info->{default_route_v4} = $gateway;
|
||
}
|
||
}
|
||
return $info;
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Name resolution
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# The transport is probed once: getent implements getaddrinfo directly, so it is
|
||
# preferred, and host is the fallback for systems without the ahosts databases.
|
||
sub resolver_transport {
|
||
return $RESOLVER if defined $RESOLVER;
|
||
$RESOLVER = '';
|
||
if (defined find_exe('getent')) {
|
||
my ($out, $run_status) = run(['getent', 'ahostsv4', 'localhost']);
|
||
$RESOLVER = 'getent' if $run_status eq 'ok' && index($out, 'localhost') >= 0;
|
||
}
|
||
$RESOLVER = 'host' if !$RESOLVER && defined find_exe('host');
|
||
return $RESOLVER;
|
||
}
|
||
|
||
# Resolve a name for one address family, in resolver order, with IPv4-mapped
|
||
# answers excluded. An empty list means the name has no address of that family.
|
||
sub resolve_family {
|
||
my ($host, $family) = @_;
|
||
my $transport = resolver_transport();
|
||
return () if $transport eq '';
|
||
|
||
if ($transport eq 'getent') {
|
||
my ($out, $run_status) = run(['getent', $family eq 'v6' ? 'ahostsv6' : 'ahostsv4', $host]);
|
||
return () unless $run_status eq 'ok';
|
||
my @addrs;
|
||
for my $line (split /\n/, $out, -1) {
|
||
my @parts = split ' ', $line;
|
||
next unless @parts >= 2 && $parts[1] eq 'STREAM';
|
||
next if is_mapped6($parts[0]);
|
||
push @addrs, $parts[0];
|
||
}
|
||
return @addrs;
|
||
}
|
||
|
||
my ($out, $run_status) = run(['host', '-W', 3, '-t', $family eq 'v6' ? 'AAAA' : 'A', $host]);
|
||
return () unless $run_status eq 'ok';
|
||
my @addrs;
|
||
for my $line (split /\n/, $out, -1) {
|
||
if ($family eq 'v6') {
|
||
push @addrs, $1 if $line =~ /\bhas IPv6 address (\S+)/;
|
||
}
|
||
else {
|
||
push @addrs, $1 if $line =~ /\bhas address (\S+)/;
|
||
}
|
||
}
|
||
return @addrs;
|
||
}
|
||
|
||
# The resolver runs as a separate process, so its start-up cost sits inside every
|
||
# sample taken around it. That cost is measured once against a name that never
|
||
# leaves the machine and subtracted, leaving the resolution itself. The
|
||
# subtraction is conservative: the calibration name is answered from the hosts
|
||
# file and so never exercises the code path a network query goes through, which
|
||
# leaves a residual measured at about 3 ms per sample on this workstation. That
|
||
# residual is a fraction of the 20 ms that separates one DNS score from the next,
|
||
# so it does not move the grade, and it is recorded rather than hidden because
|
||
# the figure is not exact.
|
||
sub resolver_overhead {
|
||
return $RESOLVER_OVERHEAD if defined $RESOLVER_OVERHEAD;
|
||
$RESOLVER_OVERHEAD = 0;
|
||
return 0 unless $HAVE_HIRES && resolver_transport() ne '';
|
||
my @samples;
|
||
for (1 .. 5) {
|
||
my $start = now();
|
||
my @ignored = resolve_family('localhost', 'v4');
|
||
push @samples, (now() - $start) * 1000;
|
||
}
|
||
@samples = sort { $a <=> $b } @samples;
|
||
$RESOLVER_OVERHEAD = $samples[int(@samples / 2)];
|
||
return $RESOLVER_OVERHEAD;
|
||
}
|
||
|
||
sub dns_samples {
|
||
my ($domain, $family) = @_;
|
||
# One untimed resolution first. The resolver's machinery, an NSS module for
|
||
# instance, is loaded once per process, and letting the first sample pay for
|
||
# that would report the loader instead of the resolver. Measured here: the
|
||
# first AAAA sample taken in a fresh process cost 37 ms against 3 ms for the
|
||
# rest, because the calibration below resolves a name that never reaches the
|
||
# module in question.
|
||
my @warm_up = resolve_family($domain, $family);
|
||
my @results;
|
||
for (1 .. 3) {
|
||
my $start = now();
|
||
my @addrs = resolve_family($domain, $family);
|
||
my $ms;
|
||
if (defined $start) {
|
||
$ms = (now() - $start) * 1000 - resolver_overhead();
|
||
$ms = 0 if $ms < 0;
|
||
}
|
||
my %sample = (ip => (@addrs ? $addrs[0] : 'N/A'));
|
||
$sample{ms} = defined $ms ? round1($ms) : -1;
|
||
push @results, \%sample;
|
||
}
|
||
return \@results;
|
||
}
|
||
|
||
# The machine's own name, and its fully qualified form. The hostname comes from
|
||
# uname; the qualified name is only chased when the short name carries no dot.
|
||
sub check_hostname {
|
||
my ($out, $run_status) = run(['uname', '-n']);
|
||
my $name = $run_status eq 'ok' ? $out : '';
|
||
$name =~ s/\s+$//;
|
||
return $name;
|
||
}
|
||
|
||
sub check_fqdn {
|
||
my ($name) = @_;
|
||
return '' unless length $name;
|
||
return $name if index($name, '.') >= 0;
|
||
my ($canonical, $aliases, $addrtype, $length, @addresses) = gethostbyname($name);
|
||
return $name unless @addresses;
|
||
my ($reverse, $r_aliases) = gethostbyaddr($addresses[0], $AF_INET);
|
||
return $name unless defined $reverse && index($reverse, '.') >= 0;
|
||
return $reverse;
|
||
}
|
||
|
||
sub check_dns {
|
||
my ($protocol) = @_;
|
||
my $hostname = check_hostname();
|
||
my %info = (
|
||
hostname => $hostname,
|
||
fqdn => check_fqdn($hostname),
|
||
resolvers => [],
|
||
v4 => {},
|
||
v6 => {},
|
||
);
|
||
# Without a clock the latency column has nothing to report, and the grade
|
||
# leaves that component out rather than scoring a figure that was not taken.
|
||
$info{no_clock} = 1 unless $HAVE_HIRES;
|
||
|
||
for my $entry (@CONNECTIVITY_HOSTS) {
|
||
my $domain = $entry->[0];
|
||
$info{v6}{$domain} = dns_samples($domain, 'v6') if $protocol ne 'v4';
|
||
$info{v4}{$domain} = dns_samples($domain, 'v4') if $protocol ne 'v6';
|
||
}
|
||
|
||
if (open(my $fh, '<', '/etc/resolv.conf')) {
|
||
while (my $line = <$fh>) {
|
||
next unless $line =~ /^nameserver/;
|
||
my @parts = split ' ', $line;
|
||
push @{ $info{resolvers} }, $parts[1] if @parts >= 2;
|
||
}
|
||
close($fh);
|
||
}
|
||
return \%info;
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# TCP reachability
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# A TCP handshake to one host over one family. Candidates are tried in resolver
|
||
# order and the first success wins; the timing covers the connect alone.
|
||
sub tcp_probe {
|
||
my ($host, $port, $family) = @_;
|
||
my @addrs = resolve_family($host, $family);
|
||
return { reachable => 0 } unless @addrs;
|
||
|
||
for my $addr (@addrs) {
|
||
my $sockaddr = $family eq 'v6' ? sa_in6($addr, $port) : sa_in($addr, $port);
|
||
next unless defined $sockaddr;
|
||
my $family_const = $family eq 'v6' ? af_inet6() : $AF_INET;
|
||
socket(my $sock, $family_const, $SOCK_STREAM, $IPPROTO_TCP) or next;
|
||
|
||
my $start = now();
|
||
my $connected = 0;
|
||
eval {
|
||
local $SIG{ALRM} = sub { die "alarm\n" };
|
||
alarm(5);
|
||
$connected = connect($sock, $sockaddr);
|
||
alarm(0);
|
||
1;
|
||
} or do { $connected = 0; alarm(0) };
|
||
my $ms = defined $start ? round1((now() - $start) * 1000) : undef;
|
||
close($sock);
|
||
next unless $connected;
|
||
|
||
my %result = (reachable => 1, ip => $addr);
|
||
$result{ms} = $ms if defined $ms;
|
||
return \%result;
|
||
}
|
||
return { reachable => 0 };
|
||
}
|
||
|
||
# TCP handshake probes to well-known hosts over both families, IPv6 first. This
|
||
# is the only place TCP probes are made; the per-family reachability sections
|
||
# reuse these results. A family excluded with --protocol is left empty, so the
|
||
# reachability section and the grade skip it instead of penalising a probe the
|
||
# user asked not to make.
|
||
sub check_connectivity {
|
||
my ($protocol) = @_;
|
||
my %info = (v4 => {}, v6 => {});
|
||
for my $entry (@CONNECTIVITY_HOSTS) {
|
||
my ($host, $port) = @$entry;
|
||
$info{v6}{$host} = tcp_probe($host, $port, 'v6') if $protocol ne 'v4';
|
||
$info{v4}{$host} = tcp_probe($host, $port, 'v4') if $protocol ne 'v6';
|
||
}
|
||
return \%info;
|
||
}
|
||
|
||
# The best address for the target over one family, preferring IPv6, together with
|
||
# the family it belongs to. Resolving here rather than letting ping decide keeps
|
||
# the family deterministic, which the MTU header arithmetic depends on.
|
||
sub resolve_probe_target {
|
||
my ($target, $protocol) = @_;
|
||
my @order = $protocol eq 'auto' ? ('v6', 'v4') : ($protocol);
|
||
for my $family (@order) {
|
||
my @addrs = resolve_family($target, $family);
|
||
return ($family, $addrs[0]) if @addrs;
|
||
}
|
||
return (undef, undef);
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Path MTU
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# A DF probe walk from 1500 downwards over one family. Success is a parsed
|
||
# reply, and header sizes are per family: 28 bytes for IPv4, 48 for IPv6. Every
|
||
# failure falls through to the next size, whether it was a definitive "too big"
|
||
# answer or a timeout. Returns the largest size that drew a reply (0 when none
|
||
# did) and, when the ping binary itself is missing, the method note for it.
|
||
sub mtu_probe_walk {
|
||
my ($addr, $family, $os_type) = @_;
|
||
my $header = $family eq 'v6' ? 48 : 28;
|
||
|
||
my $base = ping_base_cmd($family);
|
||
my @df_args = $os_type eq 'freebsd' ? ('-D') : ('-M', 'do');
|
||
my @wait_args = @{ ping_wait_args($os_type, 2) };
|
||
|
||
for my $size (1500, 1400, 1300, 1280, 1200, 1000) {
|
||
my $payload = $size - $header;
|
||
my @cmd = (@$base, @df_args, '-c', 1, @wait_args, '-s', $payload, '--', $addr);
|
||
my ($out, $run_status) = run(\@cmd, 12);
|
||
return (0, "'$base->[0]' not found") if $run_status eq 'notfound';
|
||
my ($latencies, $received) = parse_ping_output($out);
|
||
return ($size, undef) if defined $received && $received > 0;
|
||
}
|
||
return (0, undef);
|
||
}
|
||
|
||
sub check_mtu {
|
||
my ($target, $protocol, $os_type) = @_;
|
||
my %info = (path_mtu => 0, target => $target, method => '');
|
||
my %family_label = (v4 => 'IPv4', v6 => 'IPv6');
|
||
|
||
my ($family, $addr) = resolve_probe_target($target, $protocol);
|
||
if (!defined $family) {
|
||
$info{method} = 'target did not resolve';
|
||
return \%info;
|
||
}
|
||
|
||
my ($size, $missing) = mtu_probe_walk($addr, $family, $os_type);
|
||
if (defined $missing) {
|
||
$info{method} = $missing;
|
||
return \%info;
|
||
}
|
||
|
||
# A name that resolves over the preferred family but has no route there must
|
||
# not read as a missing path MTU: with --protocol auto the other family gets
|
||
# the same walk before the section gives up. An explicit --protocol keeps
|
||
# the single family the user asked for.
|
||
if (!$size && $protocol eq 'auto') {
|
||
my $other = $family eq 'v6' ? 'v4' : 'v6';
|
||
my @addrs = resolve_family($target, $other);
|
||
if (@addrs) {
|
||
my ($alt_size, $alt_missing) = mtu_probe_walk($addrs[0], $other, $os_type);
|
||
if (defined $alt_missing) {
|
||
$info{method} = $alt_missing;
|
||
return \%info;
|
||
}
|
||
if ($alt_size) {
|
||
$info{path_mtu} = $alt_size;
|
||
$info{method} = "ping DF probe (${alt_size}B OK, $family_label{$other} fallback)";
|
||
return \%info;
|
||
}
|
||
}
|
||
}
|
||
|
||
if ($size) {
|
||
$info{path_mtu} = $size;
|
||
$info{method} = "ping DF probe (${size}B OK)";
|
||
}
|
||
else {
|
||
$info{method} = 'ping DF probe (no probe size succeeded)';
|
||
}
|
||
return \%info;
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Listening ports
|
||
# ---------------------------------------------------------------------------
|
||
|
||
sub parse_ss_output {
|
||
my ($out) = @_;
|
||
my @lines = split /\n/, $out, -1;
|
||
shift @lines; # header
|
||
my @entries;
|
||
for my $line (@lines) {
|
||
next unless index($line, 'LISTEN') >= 0;
|
||
my @parts = split ' ', $line;
|
||
next if @parts < 5;
|
||
# State Recv-Q Send-Q LocalAddress:Port PeerAddress:Port Process
|
||
my $local = $parts[3];
|
||
push @entries, {
|
||
addr => $local,
|
||
# A process name may contain a space, so the tail is joined whole.
|
||
process => (@parts > 5 ? join(' ', @parts[5 .. $#parts]) : ''),
|
||
# IPv6 sockets are written in bracket notation, [::]:port
|
||
bucket => index($local, '[') == 0 ? 'tcp6' : 'tcp4',
|
||
};
|
||
}
|
||
return @entries;
|
||
}
|
||
|
||
sub listening_ports {
|
||
my ($os_type) = @_;
|
||
return listening_ports_freebsd() if $os_type eq 'freebsd';
|
||
return listening_ports_linux();
|
||
}
|
||
|
||
sub listening_ports_linux {
|
||
my %info = (tcp4 => [], tcp6 => [], tcp46 => [], error => '');
|
||
my ($out, $run_status) = run(['ss', '-tlnp'], 5);
|
||
if ($run_status eq 'notfound') {
|
||
$info{error} = "'ss' not found";
|
||
return \%info;
|
||
}
|
||
my @entries = parse_ss_output($out);
|
||
|
||
# Ports owned by other users come back without a process name; sudo without a
|
||
# password prompt fills those in where it can.
|
||
if (grep { $_->{process} eq '' } @entries) {
|
||
my ($sudo_out, $sudo_status) = run(['sudo', '-n', 'ss', '-tlnp'], 5);
|
||
if ($sudo_status eq 'ok' && length $sudo_out) {
|
||
my %by_addr;
|
||
$by_addr{ $_->{addr} } = $_ for parse_ss_output($sudo_out);
|
||
for my $entry (@entries) {
|
||
next unless $entry->{process} eq '' && exists $by_addr{ $entry->{addr} };
|
||
$entry->{process} = $by_addr{ $entry->{addr} }{process};
|
||
}
|
||
}
|
||
}
|
||
|
||
for my $entry (@entries) {
|
||
my $process = length $entry->{process} ? $entry->{process} : '(no permission)';
|
||
push @{ $info{ $entry->{bucket} } }, { addr => $entry->{addr}, process => $process };
|
||
}
|
||
return \%info;
|
||
}
|
||
|
||
sub listening_ports_freebsd {
|
||
my %info = (tcp4 => [], tcp6 => [], tcp46 => [], error => '');
|
||
my ($out, $run_status) = run(['sockstat', '-l4', '-l6'], 5);
|
||
if ($run_status eq 'notfound') {
|
||
$info{error} = "'sockstat' not found";
|
||
return \%info;
|
||
}
|
||
my @lines = split /\n/, $out, -1;
|
||
shift @lines; # header
|
||
for my $line (@lines) {
|
||
my @parts = split ' ', $line;
|
||
next if @parts < 6;
|
||
my $proto = $parts[4]; # tcp4, tcp6, or tcp46 for a dual-stack socket
|
||
next unless $proto eq 'tcp4' || $proto eq 'tcp6' || $proto eq 'tcp46';
|
||
push @{ $info{$proto} }, { addr => $parts[5], process => $parts[1] };
|
||
}
|
||
return \%info;
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Reachability sections
|
||
# ---------------------------------------------------------------------------
|
||
|
||
sub reachability_report {
|
||
my ($family, $iface_info, $probes) = @_;
|
||
my @addresses = family_addresses($iface_info, $family);
|
||
my $best = $addresses[0];
|
||
return {
|
||
available => defined $best ? 1 : 0,
|
||
addr => defined $best ? $best : '',
|
||
is_global => defined $best && address_kind($family, $best) eq 'global' ? 1 : 0,
|
||
test_sites => $probes,
|
||
};
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Grade
|
||
# ---------------------------------------------------------------------------
|
||
|
||
sub grade_letter {
|
||
my ($pct) = @_;
|
||
return 'A' if $pct >= 90;
|
||
return 'B' if $pct >= 80;
|
||
return 'C' if $pct >= 70;
|
||
return 'D' if $pct >= 60;
|
||
return 'F';
|
||
}
|
||
|
||
# Five components of twenty points each: packet loss, latency, DNS speed, IPv4
|
||
# reachability and IPv6 support. A component that was not measured, because the
|
||
# family was excluded with --protocol or because no clock was available, is
|
||
# removed from the maximum, so the letter grades the achievable points.
|
||
sub compute_grade {
|
||
my ($data) = @_;
|
||
my $score = 0;
|
||
my %breakdown;
|
||
|
||
my $ping = $data->{ping} // {};
|
||
my $loss = $ping->{loss_pct} // 100;
|
||
my $loss_score =
|
||
$loss <= 0 ? 20
|
||
: $loss <= 5 ? 15
|
||
: $loss <= 10 ? 10
|
||
: $loss <= 30 ? 5
|
||
: 0;
|
||
$breakdown{packet_loss} = $loss_score;
|
||
$score += $loss_score;
|
||
|
||
my $avg_ms = $ping->{avg_ms} // 0;
|
||
my $latency_score =
|
||
$avg_ms <= 0 ? 0
|
||
: $avg_ms < 30 ? 20
|
||
: $avg_ms < 80 ? 15
|
||
: $avg_ms < 150 ? 10
|
||
: $avg_ms < 300 ? 5
|
||
: 0;
|
||
$breakdown{latency} = $latency_score;
|
||
$score += $latency_score;
|
||
|
||
my $max_score = 100;
|
||
|
||
my $dns = $data->{dns} // {};
|
||
my $dns_score = 0;
|
||
if ($dns->{no_clock}) {
|
||
$max_score -= 20;
|
||
}
|
||
else {
|
||
my ($samples, $total) = (0, 0);
|
||
for my $family ('v6', 'v4') {
|
||
for my $domain (keys %{ $dns->{$family} // {} }) {
|
||
for my $sample (@{ $dns->{$family}{$domain} }) {
|
||
next unless $sample->{ms} > 0;
|
||
$samples++;
|
||
$total += $sample->{ms};
|
||
}
|
||
}
|
||
}
|
||
if ($samples > 0) {
|
||
my $average = $total / $samples;
|
||
$dns_score =
|
||
$average < 20 ? 20
|
||
: $average < 50 ? 15
|
||
: $average < 100 ? 10
|
||
: $average < 200 ? 5
|
||
: 0;
|
||
}
|
||
}
|
||
$breakdown{dns_speed} = $dns_score;
|
||
$score += $dns_score;
|
||
|
||
my $ipv4 = $data->{ipv4} // {};
|
||
my $v4_score = 0;
|
||
if ($ipv4->{skipped}) {
|
||
$max_score -= 20;
|
||
}
|
||
elsif ($ipv4->{available}) {
|
||
$v4_score += 10;
|
||
my $reachable = grep { $_->{reachable} } values %{ $ipv4->{test_sites} // {} };
|
||
$v4_score += $reachable * 5 > 10 ? 10 : $reachable * 5;
|
||
}
|
||
$breakdown{ipv4_reachability} = $v4_score;
|
||
$score += $v4_score;
|
||
|
||
my $ipv6 = $data->{ipv6} // {};
|
||
my $v6_score = 0;
|
||
if ($ipv6->{skipped}) {
|
||
$max_score -= 20;
|
||
}
|
||
elsif ($ipv6->{available}) {
|
||
$v6_score += 10;
|
||
my $reachable = grep { $_->{reachable} } values %{ $ipv6->{test_sites} // {} };
|
||
$v6_score += $reachable * 5 > 10 ? 10 : $reachable * 5;
|
||
}
|
||
$breakdown{ipv6_dualstack} = $v6_score;
|
||
$score += $v6_score;
|
||
|
||
my $pct = $max_score > 0 ? sprintf('%.0f', $score * 100 / $max_score) : 0;
|
||
my $letter = grade_letter($pct);
|
||
my $colour = ($letter eq 'A' || $letter eq 'B') ? $GREEN
|
||
: ($letter eq 'C' || $letter eq 'D') ? $YELLOW
|
||
: $RED;
|
||
|
||
return {
|
||
grade => $letter,
|
||
score => $score,
|
||
max_score => $max_score,
|
||
colour => $colour,
|
||
breakdown => \%breakdown,
|
||
};
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Report
|
||
# ---------------------------------------------------------------------------
|
||
|
||
sub ms_colour {
|
||
my ($ms) = @_;
|
||
return $DIM if !defined $ms || $ms <= 0;
|
||
return $GREEN if $ms < 50;
|
||
return $YELLOW if $ms < 200;
|
||
return $RED;
|
||
}
|
||
|
||
sub print_ping_block {
|
||
my ($label, $info) = @_;
|
||
return unless ref $info eq 'HASH';
|
||
if (($info->{received} // 0) == 0) {
|
||
my $note = $info->{note} // $info->{error} // '';
|
||
my $suffix = length $note ? " ($note)" : '';
|
||
print " $label: ${RED}no response$suffix$RESET\n";
|
||
return;
|
||
}
|
||
my $loss = $info->{loss_pct} // 0;
|
||
my $loss_colour = $loss > 10 ? $RED : $loss > 0 ? $YELLOW : $GREEN;
|
||
my $avg = $info->{avg_ms} // 0;
|
||
my $latency_colour = ms_colour($avg);
|
||
printf " %s: %s/%s received Loss: %s%.1f%%%s Avg: %s%.1fms%s Min/Max: %.1f/%.1fms σ: %.1fms\n",
|
||
$label,
|
||
$info->{sent} // 0, $info->{received} // 0,
|
||
$loss_colour, $loss, $RESET,
|
||
$latency_colour, $avg, $RESET,
|
||
$info->{min_ms} // 0, $info->{max_ms} // 0,
|
||
$info->{stddev_ms} // 0;
|
||
}
|
||
|
||
sub print_reachability {
|
||
my ($family, $info) = @_;
|
||
return unless ref $info eq 'HASH';
|
||
my $label = $FAMILY_LABEL->{$family};
|
||
if ($info->{skipped}) {
|
||
my $protocol_note = $family eq 'v6' ? '--protocol v4' : '--protocol v6';
|
||
print " ${DIM}○$RESET $label reachability skipped ($protocol_note)\n";
|
||
return;
|
||
}
|
||
if (!$info->{available}) {
|
||
print " ${YELLOW}○$RESET No $label address detected on any interface\n";
|
||
return;
|
||
}
|
||
my $scope = $info->{is_global} ? 'Global' : 'Private';
|
||
print " ${GREEN}✓$RESET $scope $label address: $info->{addr}\n";
|
||
my $suffix = $family eq 'v6' ? ' over IPv6' : '';
|
||
for my $entry (@CONNECTIVITY_HOSTS) {
|
||
my $site = $entry->[0];
|
||
my $result = $info->{test_sites}{$site};
|
||
next unless ref $result eq 'HASH';
|
||
if ($result->{reachable}) {
|
||
printf " %s✓%s %-20s %sms (%s)\n",
|
||
$GREEN, $RESET, $site, round1($result->{ms} // 0), $result->{ip} // '';
|
||
}
|
||
else {
|
||
print " ${RED}✗$RESET ", sprintf('%-20s', $site), " unreachable$suffix\n";
|
||
}
|
||
}
|
||
}
|
||
|
||
sub print_report {
|
||
my ($data) = @_;
|
||
my $grade_info = $data->{grade} // {};
|
||
my $grade_letter = $grade_info->{grade} // '?';
|
||
my $grade_colour = $grade_info->{colour} // $RESET;
|
||
|
||
my $bar = "═" x 60;
|
||
|
||
# Header
|
||
my $os_label = ucfirst($data->{os} // 'linux');
|
||
print "\n${BOLD}${bar}$RESET\n";
|
||
print "${BOLD} Network Diagnostics v$VERSION ($os_label)$RESET\n";
|
||
print "${BOLD}${bar}$RESET\n";
|
||
print " Hostname: $data->{hostname}\n";
|
||
print " Protocol: ", ($data->{protocol} // 'auto'), "\n";
|
||
print " Summary Grade: ${grade_colour}${BOLD}${grade_letter}$RESET ",
|
||
"(", ($grade_info->{score} // '?'), "/", ($grade_info->{max_score} // 100), ")\n";
|
||
|
||
# Interfaces
|
||
print "\n${BOLD}── Interfaces ──$RESET\n";
|
||
my $iface = $data->{interfaces} // {};
|
||
print " ${DIM}unavailable: $iface->{error}$RESET\n" if $iface->{error};
|
||
for my $entry (@{ $iface->{interfaces} // [] }) {
|
||
my $state_colour = $entry->{state} eq 'UP' ? $GREEN : $RED;
|
||
printf " %-8s %s%-5s%s %s\n",
|
||
$entry->{name}, $state_colour, $entry->{state}, $RESET,
|
||
join(', ', @{ $entry->{ips} // [] });
|
||
}
|
||
print " Default IPv6 route → $iface->{default_route_v6}\n" if $iface->{default_route_v6};
|
||
print " Default IPv4 route → $iface->{default_route_v4}\n" if $iface->{default_route_v4};
|
||
|
||
# Internet connectivity
|
||
print "\n${BOLD}── Internet Connectivity ──$RESET\n";
|
||
my $conn = $data->{connectivity} // {};
|
||
if ($conn->{error}) {
|
||
print " ${DIM}unavailable: $conn->{error}$RESET\n";
|
||
}
|
||
elsif (%$conn) {
|
||
for my $item (['IPv6', 'v6'], ['IPv4', 'v4']) {
|
||
my ($family_label, $family) = @$item;
|
||
my $family_probes = ref $conn->{$family} eq 'HASH' ? $conn->{$family} : {};
|
||
my @parts;
|
||
for my $entry (@CONNECTIVITY_HOSTS) {
|
||
my $host = $entry->[0];
|
||
my $result = $family_probes->{$host};
|
||
next unless ref $result eq 'HASH';
|
||
if ($result->{reachable}) {
|
||
my $ms = $result->{ms};
|
||
if (defined $ms) {
|
||
push @parts, sprintf("%s✓%s %s %s%.0fms%s", $GREEN, $RESET, $host, ms_colour($ms), $ms, $RESET);
|
||
}
|
||
else {
|
||
push @parts, sprintf("%s✓%s %s", $GREEN, $RESET, $host);
|
||
}
|
||
}
|
||
else {
|
||
push @parts, sprintf("%s✗%s %s", $RED, $RESET, $host);
|
||
}
|
||
}
|
||
my $hosts_line = @parts ? join(', ', @parts) : "${DIM}(none)$RESET";
|
||
print " $family_label: $hosts_line\n";
|
||
}
|
||
}
|
||
|
||
# Latency
|
||
print "\n${BOLD}── Latency (ICMP ping) ──$RESET\n";
|
||
print_ping_block('IPv6', $data->{ping_v6});
|
||
print_ping_block('IPv4', $data->{ping_v4});
|
||
|
||
# DNS
|
||
print "\n${BOLD}── DNS Resolution ──$RESET\n";
|
||
my $dns = $data->{dns} // {};
|
||
if ($dns->{error}) {
|
||
print " ${DIM}unavailable: $dns->{error}$RESET\n";
|
||
}
|
||
elsif (%$dns) {
|
||
print " FQDN: ", ($dns->{fqdn} // '?'), "\n";
|
||
print " Resolvers: ", join(', ', @{ $dns->{resolvers} // [] }), "\n" if @{ $dns->{resolvers} // [] };
|
||
print " ${DIM}latency not measured: no millisecond clock available$RESET\n" if $dns->{no_clock};
|
||
for my $item (['AAAA (IPv6)', 'v6'], ['A (IPv4)', 'v4']) {
|
||
my ($family_label, $family) = @$item;
|
||
my $domains = $dns->{$family} // {};
|
||
next unless %$domains;
|
||
print " ${BOLD}${family_label}:$RESET\n";
|
||
for my $entry (@CONNECTIVITY_HOSTS) {
|
||
my $domain = $entry->[0];
|
||
my $results = $domains->{$domain};
|
||
next unless ref $results eq 'ARRAY';
|
||
my @valid = grep { $_->{ms} > 0 } @$results;
|
||
my $average = @valid ? (eval { my $t = 0; $t += $_->{ms} for @valid; $t / scalar @valid }) : 0;
|
||
my $colour = ms_colour($average);
|
||
my @ips = grep { $_->{ip} ne 'N/A' } @$results;
|
||
my $ip_str = @ips ? $ips[0]{ip} : 'N/A';
|
||
if ($dns->{no_clock}) {
|
||
printf " %-25s → %s\n", $domain, $ip_str;
|
||
}
|
||
else {
|
||
printf " %-25s → %s%-18s%s %.0fms\n",
|
||
$domain, $colour, $ip_str, $RESET, $average;
|
||
}
|
||
}
|
||
}
|
||
}
|
||
|
||
# Reachability
|
||
print "\n${BOLD}── IPv6 Reachability ──$RESET\n";
|
||
print_reachability('v6', $data->{ipv6});
|
||
print "\n${BOLD}── IPv4 Reachability ──$RESET\n";
|
||
print_reachability('v4', $data->{ipv4});
|
||
|
||
# Path MTU
|
||
print "\n${BOLD}── Path MTU ──$RESET\n";
|
||
my $mtu = $data->{mtu} // {};
|
||
if (%$mtu) {
|
||
if ($mtu->{path_mtu}) {
|
||
my $colour = $mtu->{path_mtu} < 1500 ? $YELLOW : $GREEN;
|
||
print " ${colour}$mtu->{path_mtu}B$RESET (", ($mtu->{method} // ''), ")\n";
|
||
}
|
||
elsif ($mtu->{method}) {
|
||
print " ${DIM}$mtu->{method}$RESET\n";
|
||
}
|
||
elsif ($mtu->{error}) {
|
||
print " ${DIM}unavailable: $mtu->{error}$RESET\n";
|
||
}
|
||
}
|
||
|
||
# Listening ports
|
||
print "\n${BOLD}── Listening Ports ──$RESET\n";
|
||
my $ports = $data->{listening} // {};
|
||
if (%$ports) {
|
||
if ($ports->{error}) {
|
||
print " ${DIM}unavailable: $ports->{error}$RESET\n";
|
||
}
|
||
else {
|
||
my $total = 0;
|
||
$total += scalar @{ $ports->{$_} } for grep { ref $ports->{$_} eq 'ARRAY' } keys %$ports;
|
||
if ($total > 0) {
|
||
for my $version ('tcp6', 'tcp4', 'tcp46') {
|
||
for my $entry (@{ $ports->{$version} // [] }) {
|
||
printf " %s %-22s %s%s%s\n", $version, $entry->{addr}, $DIM, $entry->{process}, $RESET;
|
||
}
|
||
}
|
||
}
|
||
else {
|
||
print " (none)\n";
|
||
}
|
||
}
|
||
}
|
||
|
||
# Grade breakdown
|
||
print "\n${BOLD}── Grade Breakdown ──$RESET\n";
|
||
my $breakdown = $grade_info->{breakdown} // {};
|
||
my @labels = (
|
||
['packet_loss', 'Packet loss'],
|
||
['latency', 'Latency'],
|
||
['dns_speed', 'DNS speed'],
|
||
['ipv6_dualstack', 'IPv6 / dual-stack'],
|
||
['ipv4_reachability', 'IPv4 reachability'],
|
||
);
|
||
for my $item (@labels) {
|
||
my ($key, $label) = @$item;
|
||
my $points = $breakdown->{$key} // 0;
|
||
my $filled = int($points / 2);
|
||
my $bar_line = ("█" x $filled) . ("░" x (10 - $filled));
|
||
printf " %-20s %s %s/20\n", $label, $bar_line, $points;
|
||
}
|
||
|
||
# Footer
|
||
print "\n${BOLD}${bar}$RESET\n";
|
||
print " ${BOLD}Overall Grade: ${grade_colour}${grade_letter}$RESET ";
|
||
print "(", ($grade_info->{score} // '?'), "/", ($grade_info->{max_score} // 100), ")\n";
|
||
print "${BOLD}${bar}$RESET\n\n";
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Parallel collection
|
||
# ---------------------------------------------------------------------------
|
||
|
||
# The checks are independent and each is dominated by waiting, so they run as
|
||
# forked children, one per check. A child writes its result as a Perl literal
|
||
# into the private scratch directory and the parent reads it back once the child
|
||
# has been reaped, because the builtin pipe forms give no way to collect several
|
||
# results without a select loop over them. Progress lines appear in completion
|
||
# order.
|
||
sub scratch_dir {
|
||
return $TMP_DIR if defined $TMP_DIR;
|
||
# An empty TMPDIR counts as unset: an empty base would place the scratch
|
||
# directory at the filesystem root, where a root run would even succeed.
|
||
my $base = defined $ENV{TMPDIR} && length $ENV{TMPDIR} ? $ENV{TMPDIR} : '/tmp';
|
||
for my $attempt (0 .. 9) {
|
||
my $dir = "$base/network-diag.$$" . ($attempt ? ".$attempt" : '');
|
||
# mkdir is atomic and refuses to follow a symlink, so a hostile entry in a
|
||
# shared /tmp cannot redirect the writes.
|
||
if (mkdir($dir, 0700)) {
|
||
$TMP_DIR = $dir;
|
||
return $dir;
|
||
}
|
||
}
|
||
die "cannot create a scratch directory under $base\n";
|
||
}
|
||
|
||
sub remove_scratch {
|
||
return unless defined $TMP_DIR;
|
||
# Every forked child inherits the END block, so removal is restricted to the
|
||
# process that created the directory. Without this the first child to finish
|
||
# would delete the result files its siblings have yet to write.
|
||
return unless $$ == $PARENT_PID;
|
||
if (opendir(my $dh, $TMP_DIR)) {
|
||
for my $entry (readdir($dh)) {
|
||
next if $entry eq '.' || $entry eq '..';
|
||
unlink("$TMP_DIR/$entry");
|
||
}
|
||
closedir($dh);
|
||
}
|
||
rmdir($TMP_DIR);
|
||
undef $TMP_DIR;
|
||
}
|
||
|
||
# A value as Perl source, which is what the parent eval's back. Only the
|
||
# characters a single-quoted string cannot carry are escaped.
|
||
sub perl_literal {
|
||
my ($value) = @_;
|
||
return 'undef' unless defined $value;
|
||
if (ref $value eq 'HASH') {
|
||
return '{ ' . join(', ', map { perl_literal($_) . ' => ' . perl_literal($value->{$_}) }
|
||
sort keys %$value) . ' }';
|
||
}
|
||
if (ref $value eq 'ARRAY') {
|
||
return '[' . join(', ', map { perl_literal($_) } @$value) . ']';
|
||
}
|
||
return $value if !ref $value && $value =~ /^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?$/;
|
||
my $text = $value;
|
||
$text =~ s/([\\'])/\\$1/g;
|
||
return "'$text'";
|
||
}
|
||
|
||
sub write_literal {
|
||
my ($file, $value) = @_;
|
||
open(my $fh, '>', $file) or die "cannot write the result file $file: $!\n";
|
||
print {$fh} perl_literal($value), "\n";
|
||
close($fh) or die "cannot write the result file $file: $!\n";
|
||
return 1;
|
||
}
|
||
|
||
sub read_literal {
|
||
my ($file) = @_;
|
||
return (undef, 'result file was not written') unless -f $file;
|
||
open(my $fh, '<', $file) or return (undef, "cannot read the result: $!");
|
||
local $/ = undef;
|
||
my $text = <$fh>;
|
||
close($fh);
|
||
return (undef, 'empty result') unless defined $text && length $text;
|
||
my $value = eval $text; # written by our own child, read before it is removed
|
||
return (undef, 'unreadable result') if $@;
|
||
return ($value, '');
|
||
}
|
||
|
||
sub collect_checks {
|
||
my ($data, $os_type, $target, $protocol) = @_;
|
||
|
||
my @plan = (
|
||
['connectivity', 'internet connectivity', sub { check_connectivity($protocol) }],
|
||
);
|
||
# Only the families the user asked for, IPv6 first.
|
||
if ($protocol ne 'v4') {
|
||
push @plan, ['ping_v6', 'ping (IPv6)', sub { ping_host($target, $os_type, protocol => 'v6') }];
|
||
}
|
||
if ($protocol ne 'v6') {
|
||
push @plan, ['ping_v4', 'ping (IPv4)', sub { ping_host($target, $os_type, protocol => 'v4') }];
|
||
}
|
||
push @plan,
|
||
['dns', 'DNS resolution', sub { check_dns($protocol) }],
|
||
['mtu', 'path MTU', sub { check_mtu($target, $protocol, $os_type) }],
|
||
['listening', 'listening ports', sub { listening_ports($os_type) }];
|
||
|
||
my $dir = scratch_dir();
|
||
my (%pid_of, %file_of, %label_of);
|
||
for my $item (@plan) {
|
||
my ($key, $label, $code) = @$item;
|
||
my $file = "$dir/$key";
|
||
$file_of{$key} = $file;
|
||
$label_of{$key} = $label;
|
||
my $pid = fork();
|
||
die "cannot fork: $!\n" unless defined $pid;
|
||
if ($pid == 0) {
|
||
# A child must not inherit the parent's interrupt handling, or one
|
||
# Ctrl-C would print the message once per process.
|
||
$SIG{INT} = 'DEFAULT';
|
||
$SIG{TERM} = 'DEFAULT';
|
||
my $ok = eval { write_literal($file, $code->()) };
|
||
unless ($ok) {
|
||
my $error = $@ || 'unknown error';
|
||
$error =~ s/\s+\z//;
|
||
write_literal($file, { error => $error });
|
||
}
|
||
exit($ok ? 0 : 1);
|
||
}
|
||
$pid_of{$pid} = $key;
|
||
}
|
||
|
||
my $count = scalar @plan;
|
||
print STDERR " Running $count checks in parallel...\n";
|
||
for (1 .. $count) {
|
||
my $pid = waitpid(-1, 0);
|
||
last if $pid <= 0;
|
||
my $key = $pid_of{$pid};
|
||
next unless defined $key;
|
||
my $exit_status = $? >> 8;
|
||
my ($result, $read_error) = read_literal($file_of{$key});
|
||
my $label = $label_of{$key};
|
||
|
||
if ($exit_status != 0 || !defined $result) {
|
||
my $message = $read_error;
|
||
$message = $result->{error} if ref $result eq 'HASH' && $result->{error};
|
||
$message = 'check failed' unless defined $message && length $message;
|
||
$data->{$key} = { error => $message };
|
||
print STDERR " $label... failed ($message)\n";
|
||
next;
|
||
}
|
||
$data->{$key} = $result;
|
||
if (ref $result eq 'HASH' && $result->{note}) {
|
||
print STDERR " $label... warning ($result->{note})\n";
|
||
}
|
||
else {
|
||
print STDERR " $label... done\n";
|
||
}
|
||
}
|
||
remove_scratch();
|
||
return;
|
||
}
|
||
|
||
# ---------------------------------------------------------------------------
|
||
# Entry point
|
||
# ---------------------------------------------------------------------------
|
||
|
||
sub usage {
|
||
my $name = $0;
|
||
$name =~ s{.*/}{};
|
||
return <<"USAGE";
|
||
Usage: $name [options]
|
||
|
||
Network diagnostics: latency, DNS, MTU, dual-stack, ports
|
||
|
||
Options:
|
||
--target HOST Target host for tests (default: cloudflare.com)
|
||
--protocol FAMILY Address family: auto (dual-stack), v4 (IPv4 only),
|
||
v6 (IPv6 only) (default: auto)
|
||
--version Show the version and exit
|
||
-h, --help Show this help and exit
|
||
USAGE
|
||
}
|
||
|
||
sub parse_args {
|
||
my %opt = (target => 'cloudflare.com', protocol => 'auto');
|
||
my @argv = @ARGV;
|
||
while (defined(my $arg = shift @argv)) {
|
||
if ($arg eq '--target' || $arg eq '--protocol') {
|
||
my $value = shift @argv;
|
||
if (!defined $value) {
|
||
print STDERR "argument $arg: expected one argument\n";
|
||
print STDERR usage();
|
||
exit 2;
|
||
}
|
||
$opt{ substr($arg, 2) } = $value;
|
||
}
|
||
elsif ($arg =~ /^--(target|protocol)=(.*)$/s) {
|
||
$opt{$1} = $2;
|
||
}
|
||
elsif ($arg eq '--help' || $arg eq '-h') {
|
||
print usage();
|
||
exit 0;
|
||
}
|
||
elsif ($arg eq '--version') {
|
||
my $name = $0;
|
||
$name =~ s{.*/}{};
|
||
print "$name $VERSION\n";
|
||
exit 0;
|
||
}
|
||
else {
|
||
print STDERR "unrecognised argument: $arg\n";
|
||
print STDERR usage();
|
||
exit 2;
|
||
}
|
||
}
|
||
if ($opt{protocol} ne 'auto' && $opt{protocol} ne 'v4' && $opt{protocol} ne 'v6') {
|
||
print STDERR "argument --protocol: invalid choice: '$opt{protocol}' (choose from auto, v4, v6)\n";
|
||
print STDERR usage();
|
||
exit 2;
|
||
}
|
||
return %opt;
|
||
}
|
||
|
||
sub main {
|
||
my %opt = parse_args();
|
||
my $target = $opt{target};
|
||
my $protocol = $opt{protocol};
|
||
my $os_type = detect_os();
|
||
|
||
my $hostname = check_hostname();
|
||
my $data = {
|
||
hostname => $hostname,
|
||
version => $VERSION,
|
||
os => $os_type,
|
||
protocol => $protocol,
|
||
interfaces => {},
|
||
connectivity => {},
|
||
ping => {},
|
||
ping_v4 => undef,
|
||
ping_v6 => undef,
|
||
dns => {},
|
||
ipv4 => {},
|
||
ipv6 => {},
|
||
mtu => {},
|
||
listening => {},
|
||
grade => {},
|
||
};
|
||
|
||
# Interfaces first: instant, sequential, and the reachability sections
|
||
# below depend on the result.
|
||
status('Checking interfaces');
|
||
$data->{interfaces} = interface_info($os_type);
|
||
my $iface_error = $data->{interfaces}{error};
|
||
status_done($iface_error ? "warning: $iface_error" : 'done');
|
||
|
||
collect_checks($data, $os_type, $target, $protocol);
|
||
|
||
# Per-family reachability from interface data plus the shared probes.
|
||
my $conn = $data->{connectivity} // {};
|
||
my $probes_v4 = ref $conn->{v4} eq 'HASH' ? $conn->{v4} : {};
|
||
my $probes_v6 = ref $conn->{v6} eq 'HASH' ? $conn->{v6} : {};
|
||
$data->{ipv6} = reachability_report('v6', $data->{interfaces}, $probes_v6);
|
||
$data->{ipv4} = reachability_report('v4', $data->{interfaces}, $probes_v4);
|
||
if ($protocol eq 'v4') { $data->{ipv6}{skipped} = 1 }
|
||
elsif ($protocol eq 'v6') { $data->{ipv4}{skipped} = 1 }
|
||
|
||
# The ping that summarises the run: the requested family, or IPv6 when it
|
||
# answered, which is the dual-stack preference.
|
||
if ($protocol eq 'v4') {
|
||
$data->{ping} = $data->{ping_v4} // {};
|
||
}
|
||
elsif ($protocol eq 'v6') {
|
||
$data->{ping} = $data->{ping_v6} // {};
|
||
}
|
||
else {
|
||
my $ping_v4 = $data->{ping_v4};
|
||
my $ping_v6 = $data->{ping_v6};
|
||
my $v6_received = ref $ping_v6 eq 'HASH' ? ($ping_v6->{received} // 0) : 0;
|
||
if ($v6_received > 0 && ref $ping_v6 eq 'HASH') {
|
||
$data->{ping} = $ping_v6;
|
||
}
|
||
elsif (ref $ping_v4 eq 'HASH') {
|
||
$data->{ping} = $ping_v4;
|
||
}
|
||
else {
|
||
$data->{ping} = {};
|
||
}
|
||
}
|
||
|
||
$data->{grade} = compute_grade($data);
|
||
print_report($data);
|
||
return 0;
|
||
}
|
||
|
||
$SIG{INT} = sub {
|
||
print STDERR "\nInterrupted.\n";
|
||
remove_scratch();
|
||
exit 130;
|
||
};
|
||
$SIG{TERM} = sub {
|
||
remove_scratch();
|
||
exit 143;
|
||
};
|
||
END {
|
||
remove_scratch();
|
||
}
|
||
|
||
exit(main()) unless caller;
|