feat: initial release of the scripts collection
Assisted-by: GLM 5.3 Flash
This commit is contained in:
@@ -0,0 +1,732 @@
|
||||
#!/usr/bin/perl
|
||||
# Rig for sglang-deploy.pl: runs the real script as root inside a container against
|
||||
# stub commands, and checks the state, the written files and the exit codes it leaves.
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# The rig file lives beside this repository's other checks, everything it writes lives
|
||||
# in a work directory that is bind mounted into the container, and the script under test
|
||||
# is the one in the repository root.
|
||||
my $RIG = $0 =~ m{^(.*)/[^/]+$} ? $1 : '.';
|
||||
my $WORK = $ENV{SGLANG_RIG_WORK} // '/tmp/sglang-rig';
|
||||
my $BIN = "$WORK/bin";
|
||||
my $FIX = "$WORK/fixture";
|
||||
my $ST = "$WORK/state";
|
||||
my $LOG = "$WORK/log/stubs.log";
|
||||
my $SCRIPT = $ENV{SGLANG_RIG_SCRIPT} // "$RIG/../../sglang-deploy.pl";
|
||||
my $UNIT = '/etc/systemd/system/sglang.service';
|
||||
my $ENVFILE = '/etc/sysconfig/sglang';
|
||||
my $NGINX = '/etc/nginx/conf.d/sglang.conf';
|
||||
my $CERTDIR = '/etc/ssl/sglang';
|
||||
my $STATEDIR = '/opt/sglang';
|
||||
|
||||
my ($passed, $failed) = (0, 0);
|
||||
my @failures;
|
||||
|
||||
sub check {
|
||||
my ($cond, $label) = @_;
|
||||
if (!defined $label || $label eq '') {
|
||||
my @stack;
|
||||
for my $i (0 .. 3) {
|
||||
my @c = caller($i);
|
||||
push @stack, join(':', $c[1] // '?', $c[2] // '?');
|
||||
}
|
||||
$label = 'no label, stack ' . join(' <- ', @stack);
|
||||
}
|
||||
if ($cond) { $passed++; print "ok $label\n"; return 1 }
|
||||
$failed++;
|
||||
push @failures, $label;
|
||||
print "FAIL $label\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# The verdict is forced into a boolean: a bare match in a sub argument list is a list
|
||||
# context, where a failed match yields the empty list and would shift the label into
|
||||
# the condition slot, turning a failure into a silent pass.
|
||||
sub check_like {
|
||||
my ($text, $re, $label) = @_;
|
||||
$label = 'check_like without a label' unless defined $label;
|
||||
my $matched = (defined $text && $text =~ $re) ? 1 : 0;
|
||||
return check($matched, $label);
|
||||
}
|
||||
|
||||
sub check_unlike {
|
||||
my ($text, $re, $label) = @_;
|
||||
$label = 'check_unlike without a label' unless defined $label;
|
||||
my $matched = (defined $text && $text !~ $re) ? 1 : 0;
|
||||
return check($matched, $label);
|
||||
}
|
||||
|
||||
# Directories are made and removed with the language's own calls, so no module has to
|
||||
# be installed on the machine running the rig.
|
||||
sub make_dirs {
|
||||
for my $path (@_) {
|
||||
next if -d $path;
|
||||
my @parts = split m{/}, $path;
|
||||
my $built = '';
|
||||
for my $part (@parts) {
|
||||
next unless length $part;
|
||||
$built .= "/$part";
|
||||
mkdir($built, 0755) unless -d $built;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub remove_tree {
|
||||
my ($path) = @_;
|
||||
return unless -d $path;
|
||||
if (opendir(my $dh, $path)) {
|
||||
for my $entry (readdir($dh)) {
|
||||
next if $entry eq '.' || $entry eq '..';
|
||||
my $child = "$path/$entry";
|
||||
remove_tree($child) if -d $child;
|
||||
unlink($child);
|
||||
}
|
||||
closedir($dh);
|
||||
}
|
||||
rmdir($path);
|
||||
return;
|
||||
}
|
||||
|
||||
sub slurp_file {
|
||||
my ($path) = @_;
|
||||
return '' unless -f $path;
|
||||
open(my $fh, '<', $path) or return '';
|
||||
local $/ = undef;
|
||||
my $text = <$fh>;
|
||||
close($fh);
|
||||
return defined $text ? $text : '';
|
||||
}
|
||||
|
||||
sub mode_of {
|
||||
my ($path) = @_;
|
||||
return sprintf('%04o', (stat($path))[2] & 07777);
|
||||
}
|
||||
|
||||
sub reset_fixture {
|
||||
for my $path ($UNIT, $ENVFILE, $NGINX) {
|
||||
unlink($path);
|
||||
}
|
||||
remove_tree($CERTDIR);
|
||||
remove_tree($STATEDIR);
|
||||
remove_tree($FIX);
|
||||
remove_tree($ST);
|
||||
# Directories a host that ran server-setup.pl has: nginx's configuration drop-in
|
||||
# and systemd's unit directory.
|
||||
make_dirs($FIX, $ST, "$WORK/log", '/etc/nginx/conf.d', '/etc/systemd/system');
|
||||
my $fh;
|
||||
open($fh, q{>}, $LOG) and close($fh);
|
||||
# Packages a real host or a previous run has already installed.
|
||||
write_fixture('rpm-installed', "nginx\n");
|
||||
write_fixture('fw-services', "\n");
|
||||
# firewalld is running: server-setup.pl ensures it, and the firewall step needs it.
|
||||
my $fw;
|
||||
open($fw, '>', "$ST/active.firewalld") and close($fw);
|
||||
return;
|
||||
}
|
||||
|
||||
sub write_fixture {
|
||||
my ($name, $content) = @_;
|
||||
open(my $fh, '>', "$FIX/$name") or die "cannot write $FIX/$name: $!\n";
|
||||
print {$fh} $content;
|
||||
close($fh);
|
||||
return;
|
||||
}
|
||||
|
||||
sub fixture_exists {
|
||||
my ($name) = @_;
|
||||
return -f "$FIX/$name" ? 1 : 0;
|
||||
}
|
||||
|
||||
# Run the script with the stub PATH and return (rc, merged output).
|
||||
sub run_script {
|
||||
my (@args) = @_;
|
||||
my $out_file = "$WORK/log/run.out";
|
||||
my $pid = fork();
|
||||
die "cannot fork: $!\n" unless defined $pid;
|
||||
if ($pid == 0) {
|
||||
open(STDOUT, '>', $out_file);
|
||||
open(STDERR, '>&', \*STDOUT);
|
||||
$ENV{PATH} = "$BIN:/usr/bin:/bin";
|
||||
# The stubs read the work directory from the environment, since they are
|
||||
# reached through links and cannot tell where the rig file lives.
|
||||
$ENV{STUB_WORK} = $WORK;
|
||||
exec '/usr/bin/perl', $SCRIPT, @args;
|
||||
exit 126;
|
||||
}
|
||||
waitpid($pid, 0);
|
||||
my $rc = $? >> 8;
|
||||
return ($rc, slurp_file($out_file));
|
||||
}
|
||||
|
||||
sub stub_log {
|
||||
return slurp_file($LOG);
|
||||
}
|
||||
|
||||
sub count_in_log {
|
||||
my ($pattern) = @_;
|
||||
my @lines = grep { /$pattern/ } split /\n/, stub_log();
|
||||
return scalar @lines;
|
||||
}
|
||||
|
||||
sub reset_log {
|
||||
my $fh;
|
||||
open($fh, q{>}, $LOG) and close($fh);
|
||||
return;
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Scenarios
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# The stubs are one dispatcher file reached through links named after each command,
|
||||
# so the script's own PATH lookup finds them and nothing of the real system is used.
|
||||
sub prepare_stubs {
|
||||
make_dirs($BIN, $FIX, $ST, "$WORK/log");
|
||||
for my $name (qw(lspci rpm dnf podman systemctl curl openssl nginx
|
||||
firewall-cmd getenforce getsebool setsebool)) {
|
||||
my $link = "$BIN/$name";
|
||||
# A link left over from a work directory that moved reads as broken to
|
||||
# -e, and its stale target would leave the stubs unreachable: it is
|
||||
# replaced rather than kept or died on.
|
||||
if (-l $link && !-e $link) { unlink($link) }
|
||||
next if -e $link;
|
||||
symlink("$RIG/stub.pl", $link) or die "cannot link $link: $!\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub prepare_devices {
|
||||
# The driver creates these on a real host; the rig fakes them (needs --privileged).
|
||||
return if -e q{/dev/kfd};
|
||||
system(qw(mknod /dev/kfd c 237 0));
|
||||
mkdir(q{/dev/dri}, 0755) unless -d q{/dev/dri};
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_fresh {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1] (rev 01)\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
|
||||
check($rc == 0, 'fresh: exit 0');
|
||||
check(-f $UNIT, 'fresh: unit written');
|
||||
check(-f $ENVFILE, 'fresh: environment file written');
|
||||
check(-f $NGINX, 'fresh: nginx configuration written');
|
||||
check(-f "$CERTDIR/sglang.crt" && -f "$CERTDIR/sglang.key", 'fresh: certificate written');
|
||||
check(-d "$STATEDIR/modelscope", 'fresh: model cache directory created');
|
||||
check(mode_of($ENVFILE) eq '0600', 'fresh: environment file is 0600 (' . mode_of($ENVFILE) . ')');
|
||||
check(mode_of("$CERTDIR/sglang.key") eq '0600', 'fresh: key is 0600');
|
||||
check(mode_of("$CERTDIR/sglang.crt") eq '0644', 'fresh: certificate is 0644');
|
||||
|
||||
my $env = slurp_file($ENVFILE);
|
||||
check_like($env, qr/^SGLANG_API_KEY=([A-Za-z0-9_-]{43})\n$/, 'fresh: generated key, url-safe, 43 chars');
|
||||
|
||||
my $unit = slurp_file($UNIT);
|
||||
check_like($unit, qr|docker\.io/lmsysorg/sglang:v0\.5\.19-rocm724-mi30x|, 'fresh: image resolved from ROCm 7.2.4 and MI300');
|
||||
check_like($unit, qr/--tp-size 1/, 'fresh: tensor parallel default');
|
||||
check_like($unit, qr/--context-length 4096/, 'fresh: context length default');
|
||||
check_like($unit, qr/--mem-fraction-static 0\.9/, 'fresh: memory fraction default');
|
||||
check_unlike($unit, qr/SGLANG_USE_AITER/, 'fresh: no Radeon variables on an Instinct host');
|
||||
|
||||
my $nginx = slurp_file($NGINX);
|
||||
check_like($nginx, qr|proxy_pass http://\[::1\]:8000;|, 'fresh: nginx proxies to the loopback engine');
|
||||
check_like($nginx, qr|ssl_certificate /etc/ssl/sglang/sglang\.crt;|, 'fresh: nginx uses the sglang certificate');
|
||||
|
||||
check(count_in_log(qr/^podman pull /) == 1, 'fresh: exactly one image pull');
|
||||
check_like(stub_log(), qr/^podman pull docker\.io\/lmsysorg\/sglang:v0\.5\.19-rocm724-mi30x$/m,
|
||||
'fresh: the pulled image is the resolved tag');
|
||||
check(count_in_log(qr/^systemctl enable sglang$/) == 1, 'fresh: service enabled');
|
||||
check(count_in_log(qr/^systemctl start sglang$/) == 1, 'fresh: service started');
|
||||
check_like(stub_log(), qr/^firewall-cmd --permanent --add-service=https$/m, 'fresh: HTTPS opened');
|
||||
check_like($out, qr/Engine image: docker\.io\/lmsysorg\/sglang:v0\.5\.19-rocm724-mi30x/,
|
||||
'fresh: summary names the image');
|
||||
check_like($out, qr/systemd: sglang running on \[::1\]:8000/, 'fresh: summary names the endpoint');
|
||||
check_like($out, qr/API key \(shown once, store it securely\)/, 'fresh: the generated key is shown once');
|
||||
check_unlike($out, qr/✗/, 'fresh: no failed step');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_rerun {
|
||||
scenario_fresh();
|
||||
reset_log();
|
||||
my $key_before = slurp_file($ENVFILE);
|
||||
my $unit_before = slurp_file($UNIT);
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
|
||||
check($rc == 0, 'rerun: exit 0');
|
||||
check(count_in_log(qr/^podman pull /) == 0, 'rerun: no second pull');
|
||||
check_like(stub_log(), qr/^podman image exists /m, 'rerun: the image is checked instead');
|
||||
check(count_in_log(qr/^systemctl enable sglang$/) == 0, 'rerun: no second enable');
|
||||
check(count_in_log(qr/^systemctl start sglang$/) == 0, 'rerun: no second start');
|
||||
check(count_in_log(qr/try-restart/) == 0, 'rerun: no restart, the unit did not change');
|
||||
check(count_in_log(qr/^dnf install /) == 0, 'rerun: no second package transaction');
|
||||
check(slurp_file($ENVFILE) eq $key_before, 'rerun: the API key is reused, not regenerated');
|
||||
check(slurp_file($UNIT) eq $unit_before, 'rerun: the unit file is byte-identical');
|
||||
check_like($out, qr/API key: existing key reused/, 'rerun: the key is reported as reused');
|
||||
check_like($out, qr/Engine image: already present/, 'rerun: the image is reported present');
|
||||
check_like($out, qr/systemd: sglang running/, 'rerun: the service is reported running');
|
||||
check_unlike($out, qr/would /, 'rerun: nothing is phrased as would');
|
||||
check_unlike($out, qr/✗/, 'rerun: no failed step');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_dry_run {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1] (rev 01)\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--dry-run');
|
||||
|
||||
check($rc == 0, 'dry run: exit 0');
|
||||
check(!-f $UNIT, 'dry run: no unit written');
|
||||
check(!-f $ENVFILE, 'dry run: no environment file written');
|
||||
check(!-f $NGINX, 'dry run: no nginx configuration written');
|
||||
check(!-d $CERTDIR, 'dry run: no certificate directory');
|
||||
check(count_in_log(qr/^podman pull /) == 0, 'dry run: no pull');
|
||||
check(count_in_log(qr/^systemctl (enable|start) /) == 0, 'dry run: no service change');
|
||||
check(count_in_log(qr/^dnf install /) == 0, 'dry run: no package transaction');
|
||||
check_like($out, qr/DRY RUN: no changes will be made/, 'dry run: banner');
|
||||
check_like($out, qr/would be pulled|would be installed/, 'dry run: phrased as would');
|
||||
check_like($out, qr|Engine image: docker\.io/lmsysorg/sglang:v0\.5\.19-rocm724-mi30x|,
|
||||
'dry run: the resolved image is reported');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_uninstall {
|
||||
scenario_fresh();
|
||||
reset_log();
|
||||
my ($rc, $out) = run_script('--uninstall');
|
||||
|
||||
check($rc == 0, 'uninstall: exit 0');
|
||||
check(!-f $UNIT, 'uninstall: unit removed');
|
||||
check(!-f $ENVFILE, 'uninstall: environment file removed');
|
||||
check(!-f $NGINX, 'uninstall: nginx configuration removed');
|
||||
check(!-d $CERTDIR, 'uninstall: certificate directory removed');
|
||||
check(-d $STATEDIR, 'uninstall: model cache kept');
|
||||
check(-e "$ST/image.docker.io_lmsysorg_sglang_v0.5.19-rocm724-mi30x",
|
||||
'uninstall: the image is kept in podman');
|
||||
check_like(stub_log(), qr/^systemctl stop sglang$/m, 'uninstall: service stopped');
|
||||
check_like(stub_log(), qr/^systemctl disable sglang$/m, 'uninstall: service disabled');
|
||||
check_like($out, qr/SGLang service stopped/, 'uninstall: summary reports the stop');
|
||||
check_like($out, qr/Kept on the system/, 'uninstall: the kept state is listed');
|
||||
check_like($out, qr/ModelScope cache/, 'uninstall: the cache is named as kept');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_uninstall_twice {
|
||||
scenario_uninstall();
|
||||
reset_log();
|
||||
my ($rc, $out) = run_script('--uninstall');
|
||||
check($rc == 0, 'uninstall twice: exit 0');
|
||||
check_like($out, qr/already absent/, 'uninstall twice: idempotent');
|
||||
check(count_in_log(qr/^systemctl stop /) == 0, 'uninstall twice: nothing to stop');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_radeon {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Navi 31 [Radeon RX 7900 XTX] [1002:744c] (rev c8)\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
|
||||
check($rc == 1, 'radeon: exit 1');
|
||||
check_like($out, qr/Radeon card detected/, 'radeon: names the cause');
|
||||
check_like($out, qr/rocm\.Dockerfile/, 'radeon: names the build recipe');
|
||||
check_like($out, qr/--image sglang-rocm:latest/, 'radeon: names the way forward');
|
||||
check(!-f $UNIT, 'radeon: nothing deployed');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_radeon_dev {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Strix Halo [Radeon Graphics / Radeon 8050S Graphics / Radeon 8060S Graphics] [1002:1586] (rev d1)\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
|
||||
check($rc == 0, 'radeon dev: exit 0');
|
||||
check_like(stub_log(), qr{^curl .*rocm/sgl-dev/tags\?.*$}m,
|
||||
'radeon dev: the AMD tag index is asked for the newest build');
|
||||
my $unit = slurp_file($UNIT);
|
||||
check_like($unit, qr|docker\.io/rocm/sgl-dev:v0\.5\.19-rocm724-gfx1151-20260916|,
|
||||
'radeon dev: the newest dated build is deployed');
|
||||
check_like($unit, qr/Environment=SGLANG_USE_AITER=false/, 'radeon dev: AITER off');
|
||||
check_like($unit, qr/Environment=SGLANG_ROCM_FUSED_DECODE_MLA=false/,
|
||||
'radeon dev: fused decode MLA off');
|
||||
check_like($out, qr/AMD publishes this build daily/, 'radeon dev: the moving tag is stated');
|
||||
check_like($out, qr/the only flavour published for gfx1151/, 'radeon dev: the flavour is explained');
|
||||
|
||||
reset_log();
|
||||
my ($rc2, $out2) = run_script('--model', 'ZhipuAI/GLM-5.3', '--image', 'localhost/pinned:1');
|
||||
check_like(slurp_file($UNIT), qr|localhost/pinned:1|, 'radeon dev: --image pins a build');
|
||||
check(count_in_log(qr{^curl .*rocm/sgl-dev/tags\?.*$}) == 0,
|
||||
'radeon dev: no tag resolution when --image is given');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_radeon_with_image {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Strix Halo [Radeon 8060S] [1002:150e]\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--image', 'localhost/sglang-rocm:gfx1151');
|
||||
|
||||
check($rc == 0, 'radeon with image: exit 0');
|
||||
my $unit = slurp_file($UNIT);
|
||||
check_like($unit, qr/Environment=SGLANG_USE_AITER=false/, 'radeon with image: AITER off');
|
||||
check_like($unit, qr/Environment=SGLANG_ROCM_FUSED_DECODE_MLA=false/,
|
||||
'radeon with image: fused decode MLA off');
|
||||
check_like($unit, qr|localhost/sglang-rocm:gfx1151|, 'radeon with image: the requested image');
|
||||
my ($rc2, $out2) = run_script('--model', 'ZhipuAI/GLM-5.3', '--image', 'localhost/sglang-rocm:gfx1151');
|
||||
check($rc2 == 0, 'radeon with image: rerun exit 0');
|
||||
check(slurp_file($UNIT) eq $unit, 'radeon with image: the unit is unchanged on a rerun');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_rocm_flavours {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.3\n");
|
||||
my ($rc, $out) = run_script('--dry-run', '--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like($out, qr/rocm720-mi30x/, 'flavour: ROCm 7.2.3 takes rocm720');
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "10.0.0\n");
|
||||
($rc, $out) = run_script('--dry-run', '--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like($out, qr/rocm10-mi30x/, 'flavour: ROCm 10.0.0 takes rocm10');
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI350X [1002:75a0]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
($rc, $out) = run_script('--dry-run', '--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like($out, qr/rocm724-mi35x/, 'flavour: MI350X takes mi35x');
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "6.4.0\n");
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check($rc == 1, 'flavour: an old host ROCm is refused');
|
||||
check_like($out, qr/No published image targets ROCm 6\.4\.0/, 'flavour: the refusal names the version');
|
||||
check_like($out, qr/--image/, 'flavour: the refusal names the way forward');
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
($rc, $out) = run_script('--dry-run', '--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like($out, qr/rocm10-mi30x/, 'flavour: no host ROCm takes the newest');
|
||||
check_like($out, qr/No ROCm userland found on the host/, 'flavour: the assumption is stated out loud');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_modelscope {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
write_fixture('ms.code', "200\n");
|
||||
write_fixture('ms.json', qq({"Data":{"Name":"GLM-5.3"}}\n));
|
||||
my ($rc, $out) = run_script('--dry-run', '--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like($out, qr/Verifying GLM 5\.3 on ModelScope\.\.\. found/, 'modelscope: found');
|
||||
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
write_fixture('ms.code', "404\n");
|
||||
($rc, $out) = run_script('--model', 'nope/does-not-exist');
|
||||
check($rc == 1, 'missing model: exit 1');
|
||||
check_like($out, qr/does not exist on ModelScope/, 'missing model: named as missing');
|
||||
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
# A 200 without a Name carries no usable answer: the deployment proceeds with
|
||||
# the probe marked unverified rather than blocked.
|
||||
write_fixture('ms.code', "200\n");
|
||||
write_fixture('ms.json', qq({}\n));
|
||||
($rc, $out) = run_script('--dry-run', '--model', 'ZhipuAI/GLM-5.3');
|
||||
check($rc == 0, 'modelscope: an unnamed answer does not block');
|
||||
check_like($out, qr/could not verify/, 'modelscope: the unnamed answer reads as unverified');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_hardware {
|
||||
reset_fixture();
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check($rc == 1, 'no GPU: exit 1');
|
||||
check_like($out, qr/No AMD GPU detected/, 'no GPU: named as missing');
|
||||
|
||||
# The missing driver is checked outside the rig: podman bind-mounts /dev/kfd into a
|
||||
# privileged container, so it cannot be removed from inside one.
|
||||
return;
|
||||
}
|
||||
|
||||
# Run without a GPU device node (a container without --privileged, or a host whose
|
||||
# driver is not loaded): the script must refuse and say what is missing.
|
||||
sub scenario_no_driver {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
if (-e '/dev/kfd') {
|
||||
print "skip no driver: this run has the device node (needs a run without --privileged)\n";
|
||||
return;
|
||||
}
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check($rc == 1, 'no driver: exit 1');
|
||||
check_like($out, qr/amdgpu kernel driver is not ready/, 'no driver: named as missing');
|
||||
check_like($out, qr{/dev/kfd}, 'no driver: names the device node');
|
||||
check(!-f $UNIT, 'no driver: nothing deployed');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_bad_os {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('os-release', "ID=ubuntu\nVERSION_ID=\"24.04\"\n");
|
||||
my $real = slurp_file('/etc/os-release');
|
||||
open(my $fh, '>', '/etc/os-release') or die "cannot write /etc/os-release: $!\n";
|
||||
print {$fh} slurp_file("$FIX/os-release");
|
||||
close($fh);
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--dry-run');
|
||||
open(my $back, '>', '/etc/os-release') or die "cannot restore /etc/os-release: $!\n";
|
||||
print {$back} $real;
|
||||
close($back);
|
||||
|
||||
check($rc == 1, 'bad OS: exit 1');
|
||||
check_like($out, qr/Unsupported operating system: 'ubuntu'/, 'bad OS: names the system');
|
||||
check_like($out, qr/Supported systems: Fedora, CentOS Stream, openEuler/, 'bad OS: lists the supported ones');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_validation {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--port', '443', '--dry-run');
|
||||
check($rc == 1, 'validation: port 443 refused');
|
||||
check_like($out, qr/must be 1-65535 and not 443/, 'validation: port message');
|
||||
($rc, $out) = run_script('--model', 'not-a-model-id', '--dry-run');
|
||||
check($rc == 1, 'validation: bad model ID refused');
|
||||
check_like($out, qr/Invalid model ID/, 'validation: model message');
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--gpu-memory-utilization', '1.5', '--dry-run');
|
||||
check($rc == 1, 'validation: memory fraction above 1 refused');
|
||||
check_like($out, qr/must be in \(0, 1\]/, 'validation: memory fraction message');
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--api-key', 'has space', '--dry-run');
|
||||
check($rc == 1, 'validation: whitespace API key refused');
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--rocm-flavour', 'rocm999', '--dry-run');
|
||||
check($rc == 1, 'validation: unknown flavour refused');
|
||||
check_like($out, qr/Invalid --rocm-flavour/, 'validation: flavour message');
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--image', 'bad image%name', '--dry-run');
|
||||
check($rc == 1, 'validation: image with whitespace or % refused');
|
||||
check_like($out, qr/Invalid --image/, 'validation: image message');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_api_key_argument {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--api-key', 'chosen-key-1234');
|
||||
check($rc == 0, 'api key argument: exit 0');
|
||||
check_like(slurp_file($ENVFILE), qr/^SGLANG_API_KEY=chosen-key-1234$/, 'api key argument: the key is stored');
|
||||
check_unlike($out, qr/chosen-key-1234/, 'api key argument: a given key is never echoed');
|
||||
my $unit = slurp_file($UNIT);
|
||||
check_unlike($unit, qr/chosen-key-1234/, 'api key argument: the key is not in the unit');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_non_root {
|
||||
reset_fixture();
|
||||
my $out_file = "$WORK/log/run.out";
|
||||
my $pid = fork();
|
||||
die "cannot fork: $!\n" unless defined $pid;
|
||||
if ($pid == 0) {
|
||||
open(STDOUT, '>', $out_file);
|
||||
open(STDERR, '>&', \*STDOUT);
|
||||
$ENV{PATH} = "$BIN:/usr/bin:/bin";
|
||||
$ENV{STUB_WORK} = $WORK;
|
||||
$) = 1000;
|
||||
$> = 1000;
|
||||
exec '/usr/bin/perl', $SCRIPT, '--version';
|
||||
exit 126;
|
||||
}
|
||||
waitpid($pid, 0);
|
||||
my $rc = $? >> 8;
|
||||
my $out = slurp_file($out_file);
|
||||
check($rc == 0, 'non-root: --version works without root');
|
||||
check_like($out, qr/^sglang-deploy\.pl 2\.0\.0$/, 'non-root: the version is printed');
|
||||
|
||||
my $pid3 = fork();
|
||||
die "cannot fork: $!\n" unless defined $pid3;
|
||||
if ($pid3 == 0) {
|
||||
open(STDOUT, '>', $out_file);
|
||||
open(STDERR, '>&', \*STDOUT);
|
||||
$ENV{PATH} = "$BIN:/usr/bin:/bin";
|
||||
$ENV{STUB_WORK} = $WORK;
|
||||
$) = 1000;
|
||||
$> = 1000;
|
||||
exec '/usr/bin/perl', $SCRIPT, '--model', 'ZhipuAI/GLM-5.3';
|
||||
exit 126;
|
||||
}
|
||||
waitpid($pid3, 0);
|
||||
my $rc3 = $? >> 8;
|
||||
my $out3 = slurp_file($out_file);
|
||||
check($rc3 == 1, 'non-root: exit 1');
|
||||
check_like($out3, qr/must be run as root/, 'non-root: the message says so');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_offline {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
write_fixture('image-missing', "1\n");
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check($rc == 1, 'unpublished tag: exit 1');
|
||||
check_like($out, qr/resolved image tag does not exist/, 'unpublished tag: named as missing');
|
||||
check_like($out, qr/--image/, 'unpublished tag: names the way forward');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_dependency_section {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
write_fixture('rpm-installed', "pciutils\ncurl\nopenssl\npodman\nnginx\n");
|
||||
reset_log();
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3', '--dry-run');
|
||||
check($rc == 0, 'deps: exit 0');
|
||||
check(count_in_log(qr/^dnf install /) == 0, 'deps: no transaction when all packages are present');
|
||||
check_like($out, qr/All 4 packages already installed/, 'deps: reported as present');
|
||||
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
write_fixture('rpm-installed', "\n");
|
||||
reset_log();
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like(stub_log(), qr/^dnf install -y pciutils curl openssl podman$/m,
|
||||
'deps: the four packages are installed in one transaction');
|
||||
check_like($out, qr/nginx \(reverse proxy\) is not installed: run server-setup.pl first/,
|
||||
'deps: the missing reverse proxy is warned about');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_custom_layout {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my ($rc, $out) = run_script(
|
||||
'--model', 'ZhipuAI/GLM-5.3',
|
||||
'--service-name', 'llm',
|
||||
'--state-dir', '/srv/llm',
|
||||
'--cert-dir', '/etc/ssl/llm',
|
||||
'--port', '9000',
|
||||
'--tensor-parallel', '8',
|
||||
'--max-model-len', '131072',
|
||||
'--gpu-memory-utilization', '0.85',
|
||||
);
|
||||
check($rc == 0, 'custom layout: exit 0');
|
||||
check(-f '/etc/systemd/system/llm.service', 'custom layout: the named unit is written');
|
||||
check(-f '/etc/nginx/conf.d/llm.conf', 'custom layout: the named nginx file is written');
|
||||
# The certificate file names follow the program, as they did before, not the
|
||||
# service name; the directory follows --cert-dir.
|
||||
check(-f '/etc/ssl/llm/sglang.crt', 'custom layout: certificates follow the directory');
|
||||
check(-d '/srv/llm/modelscope', 'custom layout: the state directory follows');
|
||||
my $unit = slurp_file('/etc/systemd/system/llm.service');
|
||||
check_like($unit, qr/--port 9000/, 'custom layout: port in the unit');
|
||||
check_like($unit, qr/--tp-size 8/, 'custom layout: tensor parallel in the unit');
|
||||
check_like($unit, qr/--context-length 131072/, 'custom layout: context length in the unit');
|
||||
check_like($unit, qr/--mem-fraction-static 0\.85/, 'custom layout: memory fraction in the unit');
|
||||
check_like($unit, qr|--volume /srv/llm/modelscope:/root/\.cache/modelscope:Z|,
|
||||
'custom layout: the cache volume follows the state directory');
|
||||
unlink('/etc/systemd/system/llm.service');
|
||||
unlink('/etc/nginx/conf.d/llm.conf');
|
||||
remove_tree('/etc/ssl/llm');
|
||||
remove_tree('/srv/llm');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_tls_existing {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
my $crt = slurp_file("$CERTDIR/sglang.crt");
|
||||
reset_log();
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check(slurp_file("$CERTDIR/sglang.crt") eq $crt, 'tls: an existing certificate is kept');
|
||||
check(count_in_log(qr/^openssl /) == 0, 'tls: no second certificate');
|
||||
check_like($out, qr/TLS certificate: configured/, 'tls: reported as configured');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_stale_container {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
my $fh;
|
||||
open($fh, q{>}, "$ST/container.sglang") and close($fh);
|
||||
my ($rc, $out) = run_script('--uninstall');
|
||||
check($rc == 0, 'stale container: uninstall exit 0');
|
||||
check_like(stub_log(), qr/^podman rm -f sglang$/m, 'stale container: removed');
|
||||
check(!-e "$ST/container.sglang", 'stale container: gone from podman');
|
||||
return;
|
||||
}
|
||||
|
||||
sub scenario_selinux {
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
$ENV{STUB_SELINUX} = 'Permissive';
|
||||
my ($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check(count_in_log(qr/^setsebool /) == 0, 'selinux: nothing set while permissive');
|
||||
check_like($out, qr/SELinux: permissive \(skipped\)/, 'selinux: reported as skipped');
|
||||
|
||||
reset_fixture();
|
||||
write_fixture('gpu.txt', "03:00.0 VGA compatible controller [0300]: Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1]\n");
|
||||
write_fixture('rocm.txt', "7.2.4\n");
|
||||
$ENV{STUB_SELINUX} = 'Enforcing';
|
||||
reset_log();
|
||||
($rc, $out) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check_like(stub_log(), qr/^setsebool -P httpd_can_network_connect=1$/m, 'selinux: the boolean is set');
|
||||
check_like($out, qr/SELinux: httpd_can_network_connect on/, 'selinux: reported as on');
|
||||
reset_log();
|
||||
my ($rc2, $out2) = run_script('--model', 'ZhipuAI/GLM-5.3');
|
||||
check(count_in_log(qr/^setsebool /) == 0, 'selinux: nothing set when already on');
|
||||
delete $ENV{STUB_SELINUX};
|
||||
return;
|
||||
}
|
||||
|
||||
my %scenarios = (
|
||||
fresh => \&scenario_fresh,
|
||||
rerun => \&scenario_rerun,
|
||||
dry_run => \&scenario_dry_run,
|
||||
uninstall => \&scenario_uninstall,
|
||||
uninstall_twice => \&scenario_uninstall_twice,
|
||||
radeon => \&scenario_radeon,
|
||||
radeon_dev => \&scenario_radeon_dev,
|
||||
radeon_with_image => \&scenario_radeon_with_image,
|
||||
rocm_flavours => \&scenario_rocm_flavours,
|
||||
modelscope => \&scenario_modelscope,
|
||||
hardware => \&scenario_hardware,
|
||||
bad_os => \&scenario_bad_os,
|
||||
no_driver => \&scenario_no_driver,
|
||||
validation => \&scenario_validation,
|
||||
api_key_argument => \&scenario_api_key_argument,
|
||||
non_root => \&scenario_non_root,
|
||||
offline => \&scenario_offline,
|
||||
dependencies => \&scenario_dependency_section,
|
||||
custom_layout => \&scenario_custom_layout,
|
||||
tls_existing => \&scenario_tls_existing,
|
||||
stale_container => \&scenario_stale_container,
|
||||
selinux => \&scenario_selinux,
|
||||
);
|
||||
|
||||
prepare_stubs();
|
||||
prepare_devices();
|
||||
|
||||
my @wanted = @ARGV ? @ARGV : sort keys %scenarios;
|
||||
for my $name (@wanted) {
|
||||
if (!exists $scenarios{$name}) {
|
||||
print "FAIL unknown scenario $name\n";
|
||||
$failed++;
|
||||
next;
|
||||
}
|
||||
print "\n== $name ==\n";
|
||||
$scenarios{$name}->();
|
||||
}
|
||||
|
||||
print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all " . $passed . " checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
@@ -0,0 +1,220 @@
|
||||
#!/usr/bin/perl
|
||||
# Stub commands for the sglang-deploy.pl rig. One file, dispatched by $0's basename,
|
||||
# so every stubbed tool answers from the fixture under /rig/fixture and /rig/state.
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
# Everything this stub reads and writes lives in the work directory the rig exports to
|
||||
# the script under test, which is why it is read from the environment: the stub is
|
||||
# reached through a link named after the command it stands in for.
|
||||
my $RIG = $ENV{STUB_WORK} // '/tmp/sglang-rig';
|
||||
my $FIX = "$RIG/fixture";
|
||||
my $ST = "$RIG/state";
|
||||
my $LOG = "$RIG/log/stubs.log";
|
||||
|
||||
my ($name) = $0 =~ m{([^/]+)$};
|
||||
my @args = @ARGV;
|
||||
|
||||
sub log_call {
|
||||
if (open(my $fh, '>>', $LOG)) {
|
||||
print {$fh} "$name @args\n";
|
||||
close($fh);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub fixture_text {
|
||||
my ($file, $default) = @_;
|
||||
my $path = "$FIX/$file";
|
||||
return $default unless -f $path;
|
||||
open(my $fh, '<', $path) or return $default;
|
||||
local $/ = undef;
|
||||
my $text = <$fh>;
|
||||
close($fh);
|
||||
return defined $text ? $text : $default;
|
||||
}
|
||||
|
||||
# Image names carry slashes and colons, which are not file names; the marker files keep
|
||||
# the image identity without them.
|
||||
sub state_name { my ($name) = @_; $name =~ s{[/:]}{_}g; return $name }
|
||||
sub state_exists { return -e "$ST/" . state_name($_[0]) ? 1 : 0 }
|
||||
sub touch_state {
|
||||
my $fh;
|
||||
open($fh, '>', "$ST/" . state_name($_[0])) and close($fh);
|
||||
return;
|
||||
}
|
||||
sub drop_state { unlink("$ST/" . state_name($_[0])); return }
|
||||
|
||||
log_call();
|
||||
|
||||
if ($name eq 'lspci') {
|
||||
print fixture_text('gpu.txt', '');
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'rpm') {
|
||||
my $joined = join(' ', @args);
|
||||
if ($joined =~ /%\{VERSION\}/ && $joined =~ /rocm-runtime/) {
|
||||
my $version = fixture_text('rocm.txt', '');
|
||||
$version =~ s/\s+$//;
|
||||
exit 1 unless length $version;
|
||||
print "$version\n";
|
||||
exit 0;
|
||||
}
|
||||
my $pkg = $args[-1];
|
||||
my $installed = fixture_text('rpm-installed', '');
|
||||
if ($installed =~ /^\Q$pkg\E$/m) {
|
||||
print "$pkg-1.0-1.x86_64\n";
|
||||
exit 0;
|
||||
}
|
||||
print STDERR "package $pkg is not installed\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
if ($name eq 'dnf') {
|
||||
my @pkgs = grep { !/^-/ && $_ ne 'install' } @args;
|
||||
my $installed = fixture_text('rpm-installed', '');
|
||||
for my $pkg (@pkgs) {
|
||||
$installed .= "$pkg\n" unless $installed =~ /^\Q$pkg\E$/m;
|
||||
}
|
||||
if (open(my $fh, '>', "$FIX/rpm-installed")) {
|
||||
print {$fh} $installed;
|
||||
close($fh);
|
||||
}
|
||||
print "Installing: @pkgs\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'podman') {
|
||||
my $sub = $args[0] // '';
|
||||
if ($sub eq '--version') { print "podman version 5.8.4\n"; exit 0 }
|
||||
if ($sub eq 'pull') {
|
||||
my $image = $args[-1];
|
||||
touch_state("image.$image");
|
||||
print "Pulled $image\n";
|
||||
exit 0;
|
||||
}
|
||||
if ($sub eq 'image' && ($args[1] // '') eq 'exists') {
|
||||
exit(state_exists("image.$args[2]") ? 0 : 1);
|
||||
}
|
||||
if ($sub eq 'container' && ($args[1] // '') eq 'exists') {
|
||||
exit(state_exists("container.$args[2]") ? 0 : 1);
|
||||
}
|
||||
if ($sub eq 'rm') {
|
||||
my $target = $args[-1];
|
||||
drop_state("container.$target");
|
||||
print "$target\n";
|
||||
exit 0;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'systemctl') {
|
||||
my @rest = grep { $_ !~ /^--/ } @args;
|
||||
my $verb = shift @rest // '';
|
||||
my $svc = $rest[0] // '';
|
||||
$svc =~ s/\.service$//;
|
||||
if ($verb eq 'is-active') { exit(state_exists("active.$svc") ? 0 : 1) }
|
||||
if ($verb eq 'is-enabled') { exit(state_exists("enabled.$svc") ? 0 : 1) }
|
||||
if ($verb eq 'start') { touch_state("active.$svc"); exit 0 }
|
||||
if ($verb eq 'stop') { drop_state("active.$svc"); exit 0 }
|
||||
if ($verb eq 'enable') { touch_state("enabled.$svc"); touch_state("active.$svc") if grep { $_ eq q{--now} } @args; exit 0 }
|
||||
if ($verb eq 'disable') { drop_state("enabled.$svc"); exit 0 }
|
||||
if ($verb eq 'try-restart') { exit(state_exists("active.$svc") ? 0 : 1) }
|
||||
if ($verb eq 'reload' || $verb eq 'daemon-reload') { exit 0 }
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'curl') {
|
||||
my ($url) = grep { /^https?:\/\// } @args;
|
||||
my $joined = join(' ', @args);
|
||||
$url //= '';
|
||||
if ($url =~ m{modelscope\.cn/api/v1/models/}) {
|
||||
my $code = fixture_text('ms.code', '200');
|
||||
$code =~ s/\s+$//;
|
||||
my $body = $joined =~ /__HTTP__/ ? fixture_text('ms.json', '{"Data":{"Name":"GLM-5.3"}}') : '';
|
||||
print $body;
|
||||
print "\n__HTTP__$code\n" if $joined =~ /__HTTP__/;
|
||||
exit 0;
|
||||
}
|
||||
if ($url =~ m{api\.github\.com}) {
|
||||
print fixture_text('releases.json', qq({"tag_name":"v0.5.19"}\n));
|
||||
exit 0;
|
||||
}
|
||||
if ($url =~ m{hub\.docker\.com}) {
|
||||
if (-f "$FIX/image-missing") {
|
||||
print STDERR "curl: (22) The requested URL returned error: 404\n";
|
||||
exit 22;
|
||||
}
|
||||
if ($url =~ /tags\?/) {
|
||||
# A tag listing, newest first: the rig's AMD development build.
|
||||
print qq({"results":[{"name":"v0.5.19-rocm724-gfx1151-20260916"}]}\n);
|
||||
exit 0;
|
||||
}
|
||||
print qq({"name":"ok"}\n);
|
||||
exit 0;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'openssl') {
|
||||
my %want;
|
||||
for my $i (0 .. $#args) {
|
||||
if ($args[$i] eq '-keyout') { $want{key} = $args[$i + 1] }
|
||||
if ($args[$i] eq '-out') { $want{crt} = $args[$i + 1] }
|
||||
if ($args[$i] eq '-subj') { $want{subj} = $args[$i + 1] }
|
||||
if ($args[$i] eq '-addext') { $want{san} = $args[$i + 1] }
|
||||
}
|
||||
for my $kind (qw(key crt)) {
|
||||
my $path = $want{$kind};
|
||||
next unless defined $path;
|
||||
if (open(my $fh, '>', $path)) {
|
||||
print {$fh} "stub $kind $want{subj} $want{san}\n";
|
||||
close($fh);
|
||||
}
|
||||
else {
|
||||
print STDERR "can't open $path\n";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'nginx') {
|
||||
print "nginx: configuration file /etc/nginx/nginx.conf test is successful\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'firewall-cmd') {
|
||||
my $joined = join(' ', @args);
|
||||
if ($joined =~ /--list-services/) {
|
||||
print fixture_text('fw-services', "\n");
|
||||
exit 0;
|
||||
}
|
||||
if ($joined =~ /--add-service=https/) {
|
||||
my $fh;
|
||||
open($fh, q{>>}, "$FIX/fw-services") and print {$fh} "https\n" and close($fh);
|
||||
exit 0;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'getenforce') {
|
||||
my $mode = $ENV{STUB_SELINUX} // 'Enforcing';
|
||||
print "$mode\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'getsebool') {
|
||||
my $value = state_exists('sebool') ? 'on' : 'off';
|
||||
print "httpd_can_network_connect --> $value\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if ($name eq 'setsebool') {
|
||||
touch_state('sebool');
|
||||
exit 0;
|
||||
}
|
||||
|
||||
exit 0;
|
||||
@@ -0,0 +1,316 @@
|
||||
#!/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);
|
||||
@@ -0,0 +1,706 @@
|
||||
#!/usr/bin/env perl
|
||||
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||||
# SPDX-License-Identifier: MIT
|
||||
|
||||
# Checks for security-audit.pl: the SSH configuration readers and their
|
||||
# evaluator, the socket and firewall parsers with their coverage and exposure
|
||||
# rules, SELinux, updates, accounts, the kernel hardening verdicts, the deep
|
||||
# scan evaluator, the grade, the findings order and the JSON encoder.
|
||||
#
|
||||
# Run from anywhere: perl tests/security-audit.pl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
|
||||
$root = "./$root" if $root !~ m{^/};
|
||||
require "$root/security-audit.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) = @_;
|
||||
# A match in an argument list yields the empty list on failure, which would
|
||||
# shift the label into the condition slot, so the condition is forced first.
|
||||
return is($cond ? 1 : 0, 1, $label);
|
||||
}
|
||||
|
||||
sub like {
|
||||
my ($got, $re, $label) = @_;
|
||||
my $matched = (defined $got && $got =~ $re) ? 1 : 0;
|
||||
if ($matched) {
|
||||
$passed++;
|
||||
print "ok $label\n";
|
||||
return 1;
|
||||
}
|
||||
$failed++;
|
||||
print "FAIL $label\n got: " . (defined $got ? $got : 'undef') . "\n want: $re\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# The severity a check id carries in a list of checks, and the message with it.
|
||||
sub severity_of {
|
||||
my ($checks, $id) = @_;
|
||||
for my $check (@$checks) {
|
||||
return ($check->{severity}, $check->{message}) if $check->{id} eq $id;
|
||||
}
|
||||
return ('missing', '');
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# RPM version comparison
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(rpmvercmp('1.0', '1.0'), 0, 'rpmvercmp: equal');
|
||||
is(rpmvercmp('1.0', '1.0.1'), -1, 'rpmvercmp: an extra segment is newer');
|
||||
is(rpmvercmp('2.0', '1.9.9'), 1, 'rpmvercmp: the major decides');
|
||||
is(rpmvercmp('1.10', '1.9'), 1, 'rpmvercmp: numeric segments compare by value');
|
||||
is(rpmvercmp('1.007', '1.7'), 0, 'rpmvercmp: leading zeros are stripped');
|
||||
is(rpmvercmp('1.0~rc1', '1.0'), -1, 'rpmvercmp: tilde sorts before the release');
|
||||
is(rpmvercmp('1.0~rc1', '1.0~rc2'), -1, 'rpmvercmp: two pre releases');
|
||||
is(rpmvercmp('1.0.fc41', '1.0.fc41'), 0, 'rpmvercmp: identical dist tags');
|
||||
is(rpmvercmp('6.12.4-200.fc41', '6.12.4-100.fc41'), 1, 'rpmvercmp: a kernel release');
|
||||
is(rpmvercmp('1.0b', '1.0'), 1, 'rpmvercmp: an alpha suffix is newer than none');
|
||||
is(rpmvercmp('1.0', '1.0b'), -1, 'rpmvercmp: and the mirror side');
|
||||
is(rpmvercmp('2016a', '2015616'), -1, 'rpmvercmp: a numeric segment beats an alpha one');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# SSH configuration
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my ($values, $ports) = parse_sshd_effective(<<'SSHD');
|
||||
port 22
|
||||
port 2222
|
||||
addressfamily any
|
||||
listenaddress 0.0.0.0:22
|
||||
permitrootlogin prohibit-password
|
||||
passwordauthentication no
|
||||
permitemptypasswords no
|
||||
pubkeyauthentication yes
|
||||
x11forwarding no
|
||||
maxauthtries 3
|
||||
SSHD
|
||||
is($values->{permitrootlogin}, 'prohibit-password', 'sshd -T: a keyword reads back');
|
||||
is($values->{passwordauthentication}, 'no', 'sshd -T: the key is lowercased');
|
||||
is(scalar @$ports, 2, 'sshd -T: both port lines are kept');
|
||||
is($ports->[1], 2222, 'sshd -T: the second port in order');
|
||||
|
||||
my $tmp_dir = "/tmp/security-audit-test.$$";
|
||||
mkdir($tmp_dir, 0700) or die "cannot mkdir $tmp_dir: $!\n";
|
||||
open(my $main_fh, '>', "$tmp_dir/sshd_config") or die "cannot write: $!\n";
|
||||
print {$main_fh} <<'CONF';
|
||||
# a comment
|
||||
Port 22
|
||||
PasswordAuthentication yes
|
||||
|
||||
Match User backup
|
||||
PasswordAuthentication no
|
||||
CONF
|
||||
close($main_fh);
|
||||
open(my $drop_fh, '>', "$tmp_dir/50-audit.conf") or die "cannot write: $!\n";
|
||||
print {$drop_fh} "PasswordAuthentication no\nMaxAuthTries 2\n";
|
||||
close($drop_fh);
|
||||
|
||||
my $conf_state = { values => {}, seen => {}, accum => {} };
|
||||
read_sshd_config("$tmp_dir/sshd_config", $conf_state, 0);
|
||||
is($conf_state->{values}{passwordauthentication}, 'yes', 'config: the first value wins');
|
||||
is($conf_state->{values}{permitrootlogin}, undef, 'config: an absent key stays absent');
|
||||
my $port_count = grep { $_ eq '22' } @{ $conf_state->{accum}{port} // [] };
|
||||
is($port_count, 1, 'config: the port accumulates');
|
||||
|
||||
# Include expansion, with a path that is not under /etc/ssh.
|
||||
open($main_fh, '>', "$tmp_dir/sshd_config") or die "cannot write: $!\n";
|
||||
print {$main_fh} "Include $tmp_dir/*.conf\nPasswordAuthentication yes\n";
|
||||
close($main_fh);
|
||||
$conf_state = { values => {}, seen => {}, accum => {} };
|
||||
read_sshd_config("$tmp_dir/sshd_config", $conf_state, 0);
|
||||
is($conf_state->{values}{passwordauthentication}, 'no',
|
||||
'config: an include is read before the lines after it');
|
||||
is($conf_state->{values}{maxauthtries}, '2', 'config: the drop-in carries its own key');
|
||||
# The Match block of the first fixture must not be picked up either: the first
|
||||
# value is the one a global reading of the file yields, which is what the
|
||||
# fallback promises.
|
||||
|
||||
# A Match block alone sets nothing: everything after the Match line is
|
||||
# conditional on a pattern the fallback cannot evaluate.
|
||||
open($main_fh, '>', "$tmp_dir/sshd_config") or die "cannot write: $!\n";
|
||||
print {$main_fh} "Match User admin\n PermitRootLogin yes\n";
|
||||
close($main_fh);
|
||||
$conf_state = { values => {}, seen => {}, accum => {} };
|
||||
read_sshd_config("$tmp_dir/sshd_config", $conf_state, 0);
|
||||
is($conf_state->{values}{permitrootlogin}, undef, 'config: a Match block alone sets nothing');
|
||||
|
||||
sub ssh_values {
|
||||
my %pair = @_;
|
||||
my %values;
|
||||
$values{$_} = $pair{$_} for keys %pair;
|
||||
return \%values;
|
||||
}
|
||||
|
||||
my @checks = evaluate_ssh({
|
||||
available => 1, source => 'effective',
|
||||
values => ssh_values(
|
||||
permitrootlogin => 'yes', passwordauthentication => 'no',
|
||||
permitemptypasswords => 'no', pubkeyauthentication => 'yes',
|
||||
x11forwarding => 'no', maxauthtries => '3',
|
||||
),
|
||||
ports => [22],
|
||||
});
|
||||
is((severity_of(\@checks, 'ssh.permit_root_login'))[0], 'critical',
|
||||
'ssh: root login yes is critical');
|
||||
|
||||
@checks = evaluate_ssh({
|
||||
available => 1, source => 'config',
|
||||
values => ssh_values(
|
||||
permitrootlogin => 'prohibit-password', passwordauthentication => 'yes',
|
||||
permitemptypasswords => 'yes',
|
||||
),
|
||||
ports => [22],
|
||||
});
|
||||
is((severity_of(\@checks, 'ssh.permit_root_login'))[0], 'pass',
|
||||
'ssh: prohibit-password passes');
|
||||
is((severity_of(\@checks, 'ssh.password_authentication'))[0], 'warn',
|
||||
'ssh: password authentication on is a warning');
|
||||
is((severity_of(\@checks, 'ssh.permit_empty_passwords'))[0], 'critical',
|
||||
'ssh: empty passwords permitted is critical');
|
||||
is((severity_of(\@checks, 'ssh.max_auth_tries'))[0], 'pass',
|
||||
'ssh: an absent MaxAuthTries falls back to OpenSSH default and passes');
|
||||
is((severity_of(\@checks, 'ssh.max_auth_tries'))[1], 'MaxAuthTries 6',
|
||||
'ssh: the OpenSSH default for MaxAuthTries is 6');
|
||||
|
||||
# sshd accepts and lowercases the Yes and No values, so an uppercase value in
|
||||
# the configuration file is graded by its meaning and not by its case.
|
||||
@checks = evaluate_ssh({
|
||||
available => 1, source => 'config',
|
||||
values => ssh_values(permitrootlogin => 'YES', passwordauthentication => 'No'),
|
||||
ports => [22],
|
||||
});
|
||||
is((severity_of(\@checks, 'ssh.permit_root_login'))[0], 'critical',
|
||||
'ssh: an uppercase Yes is still root login yes');
|
||||
is((severity_of(\@checks, 'ssh.password_authentication'))[0], 'pass',
|
||||
'ssh: an uppercase No still turns password auth off');
|
||||
|
||||
@checks = evaluate_ssh({ available => 0, source => '', values => {}, ports => [] });
|
||||
is(scalar @checks, 0, 'ssh: an unavailable source yields no checks');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Sockets
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my @listeners = @{
|
||||
parse_ss_listeners(<<'SS')
|
||||
tcp LISTEN 0 128 0.0.0.0:22 0.0.0.0:* users:(("sshd",pid=1180,fd=3))
|
||||
tcp LISTEN 0 5 192.168.1.7:5432 0.0.0.0:* users:(("postgres",pid=900,fd=5))
|
||||
tcp LISTEN 0 128 127.0.0.1:6379 0.0.0.0:*
|
||||
tcp LISTEN 0 128 [::1]:6379 [::]:*
|
||||
tcp LISTEN 0 128 [::]:80 [::]:* users:(("nginx",pid=800,fd=6))
|
||||
udp UNCONN 0 0 0.0.0.0:5353 0.0.0.0:*
|
||||
udp UNCONN 0 0 [fe80::a7f4:eb68:1d07:aac3]%wlp1s0:3702 [::]:* users:(("wsdd",pid=7,fd=13))
|
||||
tcp ESTAB 0 0 192.168.1.7:22 192.168.1.2:51000
|
||||
SS
|
||||
};
|
||||
is(scalar @listeners, 7, 'ss: only LISTEN and UNCONN lines are sockets');
|
||||
is($listeners[0]{proto}, 'tcp', 'ss: the protocol');
|
||||
is($listeners[0]{port}, 22, 'ss: the port');
|
||||
is($listeners[0]{loopback}, 0, 'ss: a wildcard v4 socket is not loopback');
|
||||
is($listeners[0]{process}, 'sshd', 'ss: the process name');
|
||||
is($listeners[1]{loopback}, 0, 'ss: a specific address is not loopback');
|
||||
is($listeners[2]{loopback}, 1, 'ss: 127.0.0.1 is loopback');
|
||||
is($listeners[3]{loopback}, 1, 'ss: [::1] is loopback');
|
||||
is($listeners[3]{address}, '::1', 'ss: the brackets go');
|
||||
is($listeners[4]{address}, '::', 'ss: a v6 wildcard');
|
||||
is($listeners[5]{proto}, 'udp', 'ss: a udp socket is kept');
|
||||
is($listeners[6]{address}, 'fe80::a7f4:eb68:1d07:aac3',
|
||||
'ss: the scope suffix and the brackets both go');
|
||||
|
||||
is((split_listener_address('127.0.0.53%lo:53'))[0], '127.0.0.53', 'address: a v4 scope suffix');
|
||||
is((split_listener_address('garbage'))[0], undef, 'address: no port means no socket');
|
||||
is(is_loopback_address('127.255.0.1'), 1, 'address: the whole 127/8 is loopback');
|
||||
is(is_loopback_address('0.0.0.0'), 0, 'address: the wildcard is not loopback');
|
||||
is(is_wildcard_address('*'), 1, 'address: ss writes * for a v6 wildcard');
|
||||
is(is_wildcard_address('192.168.1.7'), 0, 'address: a specific address');
|
||||
is(parse_process_field('users:(("sshd",pid=1180,fd=3))'), 'sshd', 'process: the name');
|
||||
is(parse_process_field(''), '', 'process: nothing to read');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# firewalld
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my @xml_ports = parse_service_xml(<<'XML');
|
||||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<service>
|
||||
<short>SSH</short>
|
||||
<description>Secure Shell</description>
|
||||
<port port="22" protocol="tcp"/>
|
||||
</service>
|
||||
XML
|
||||
is(join(',', @xml_ports), '22/tcp', 'service xml: port first');
|
||||
|
||||
@xml_ports = parse_service_xml('<service><port protocol="udp" port="5353"/><port port="6000-6009" protocol="tcp"/></service>');
|
||||
is(join(',', @xml_ports), '5353/udp,6000-6009/tcp', 'service xml: attribute order varies and ranges pass');
|
||||
|
||||
@xml_ports = parse_service_xml('<service><description>no ports</description></service>');
|
||||
is(scalar @xml_ports, 0, 'service xml: a service without ports');
|
||||
|
||||
is(join('|', parse_active_zones("FedoraWorkstation (default)\n interfaces: wlp1s0\n")),
|
||||
'FedoraWorkstation', 'zones: the decoration is not part of the name');
|
||||
is(join('|', parse_active_zones("public\n interfaces: eth0\nwork\n interfaces: eth1\n")),
|
||||
'public|work', 'zones: two zones, the second undecorated');
|
||||
|
||||
my $info = parse_info_zone(<<'ZONE');
|
||||
FedoraWorkstation (default, active)
|
||||
target: default
|
||||
ingress-priority: 0
|
||||
interfaces: wlp1s0
|
||||
sources:
|
||||
services: dhcpv6-client samba-client ssh
|
||||
ports: 1025-65535/udp 1025-65535/tcp
|
||||
rich rules:
|
||||
ZONE
|
||||
is($info->{name}, 'FedoraWorkstation (default, active)', 'info zone: the name line');
|
||||
is($info->{target}, 'default', 'info zone: the target');
|
||||
is(join('|', @{ $info->{services} }), 'dhcpv6-client|samba-client|ssh', 'info zone: the services');
|
||||
is(join('|', @{ $info->{ports} }), '1025-65535/udp|1025-65535/tcp', 'info zone: the ports');
|
||||
|
||||
my $allowed = build_allowed([
|
||||
{
|
||||
ports => ['8080/tcp', '53/udp'],
|
||||
services => ['ssh'],
|
||||
service_ports => ['22/tcp'],
|
||||
target => 'default',
|
||||
},
|
||||
]);
|
||||
check(port_allowed($allowed, 'tcp', 22), 'coverage: a service port is allowed');
|
||||
check(port_allowed($allowed, 'tcp', 8080), 'coverage: a listed port is allowed');
|
||||
check(port_allowed($allowed, 'udp', 53), 'coverage: the protocol matters');
|
||||
check(!port_allowed($allowed, 'tcp', 8081), 'coverage: the next port is not');
|
||||
check(!port_allowed($allowed, 'tcp', 53), 'coverage: udp 53 is not tcp 53');
|
||||
|
||||
# --state answers on stdout only for a live daemon: a stopped firewalld is
|
||||
# installed but inactive, not absent.
|
||||
is(join(',', classify_firewalld(1, "running\n")), '1,1',
|
||||
'firewalld: a running daemon');
|
||||
is(join(',', classify_firewalld(1, '')), '1,0',
|
||||
'firewalld: installed but stopped is available and inactive');
|
||||
is(join(',', classify_firewalld(0, '')), '0,0',
|
||||
'firewalld: no binary is unavailable');
|
||||
|
||||
$allowed = build_allowed([ { ports => ['6000-6009/tcp'], services => [], service_ports => [] } ]);
|
||||
check(port_allowed($allowed, 'tcp', 6000), 'coverage: the start of a range');
|
||||
check(port_allowed($allowed, 'tcp', 6009), 'coverage: the end of a range');
|
||||
check(!port_allowed($allowed, 'tcp', 6010), 'coverage: past the end');
|
||||
|
||||
# The exposure model: behind a filtering zone only allowed ports are exposed;
|
||||
# an ACCEPT target exposes everything; without a firewall the socket is exposed
|
||||
# unless it sits on loopback.
|
||||
sub firewall_fixture {
|
||||
my (%override) = @_;
|
||||
my %fw = (
|
||||
available => 1, active => 1, default_zone => 'public',
|
||||
zones => [ {
|
||||
name => 'public', target => 'default',
|
||||
ports => ['8080/tcp'], services => ['ssh'], service_ports => ['22/tcp'],
|
||||
} ],
|
||||
listeners => [
|
||||
{ proto => 'tcp', address => '0.0.0.0', port => 22, loopback => 0, process => 'sshd' },
|
||||
{ proto => 'tcp', address => '0.0.0.0', port => 9999, loopback => 0, process => '' },
|
||||
{ proto => 'tcp', address => '127.0.0.1', port => 6379, loopback => 1, process => 'redis' },
|
||||
],
|
||||
);
|
||||
$fw{$_} = $override{$_} for keys %override;
|
||||
return \%fw;
|
||||
}
|
||||
|
||||
my @fw_checks = evaluate_firewall(firewall_fixture());
|
||||
my $listeners_check = (grep { $_->{id} eq 'firewall.listeners' } @fw_checks)[0];
|
||||
like($listeners_check->{message}, qr/1 exposed/, 'firewall: one socket exposed behind a filtering zone');
|
||||
is($listeners_check->{detail}[0], 'tcp 0.0.0.0:22 exposed (sshd)', 'firewall: the exposed socket is the allowed one');
|
||||
is($listeners_check->{detail}[2], 'tcp 127.0.0.1:6379 local (redis)',
|
||||
'firewall: a loopback listener is local, not filtered');
|
||||
is((severity_of(\@fw_checks, 'firewall.active'))[0], 'pass', 'firewall: running firewalld passes');
|
||||
is((severity_of(\@fw_checks, 'firewall.zone_target'))[0], 'pass', 'firewall: a filtering target passes');
|
||||
is((severity_of(\@fw_checks, 'firewall.allowed_no_listener'))[0], 'warn',
|
||||
'firewall: 8080 allowed with nothing listening is stale');
|
||||
|
||||
@fw_checks = evaluate_firewall(firewall_fixture(
|
||||
zones => [ { name => 'home', target => 'accept', ports => [], services => ['ssh'], service_ports => ['22/tcp'] } ],
|
||||
));
|
||||
is((severity_of(\@fw_checks, 'firewall.zone_target'))[0], 'warn',
|
||||
'firewall: an ACCEPT target zone is a warning');
|
||||
like((severity_of(\@fw_checks, 'firewall.listeners'))[0], qr/info/,
|
||||
'firewall: an ACCEPT target exposes the unallowed socket without failing');
|
||||
is((grep { $_->{id} eq 'firewall.listeners' } @fw_checks)[0]{message} =~ /2 exposed/ ? 'two' : 'other',
|
||||
'two', 'firewall: two sockets exposed under ACCEPT');
|
||||
|
||||
@fw_checks = evaluate_firewall(firewall_fixture(
|
||||
available => 0, active => 0, zones => [],
|
||||
));
|
||||
is((severity_of(\@fw_checks, 'firewall.active'))[0], 'critical',
|
||||
'firewall: no firewall and exposed sockets is critical');
|
||||
|
||||
@fw_checks = evaluate_firewall(firewall_fixture(
|
||||
available => 0, active => 0, zones => [],
|
||||
listeners => [ { proto => 'tcp', address => '127.0.0.1', port => 6379, loopback => 1, process => '' } ],
|
||||
));
|
||||
is((severity_of(\@fw_checks, 'firewall.active'))[0], 'warn',
|
||||
'firewall: no firewall with loopback-only sockets is a warning');
|
||||
|
||||
@fw_checks = evaluate_firewall(firewall_fixture(
|
||||
available => 1, active => 0, zones => [],
|
||||
listeners => undef,
|
||||
));
|
||||
is((severity_of(\@fw_checks, 'firewall.active'))[0], 'unknown',
|
||||
'firewall: an inactive firewall and no inventory is unknown');
|
||||
is((severity_of(\@fw_checks, 'firewall.listeners'))[0], 'unknown',
|
||||
'firewall: no ss means no inventory');
|
||||
|
||||
@fw_checks = evaluate_firewall(firewall_fixture(zones => []));
|
||||
is((severity_of(\@fw_checks, 'firewall.zone_target'))[0], 'unknown',
|
||||
'firewall: firewalld running without an active zone says so');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# SELinux
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(parse_selinux_config("# comment\nSELINUX=enforcing\n"), 'enforcing', 'selinux config: the value');
|
||||
is(parse_selinux_config("SELINUXTYPE=targeted\nSELINUX = permissive\n"), 'permissive',
|
||||
'selinux config: spaces around the assignment');
|
||||
is(parse_selinux_config("SELINUXTYPE=targeted\n"), '', 'selinux config: no SELINUX key');
|
||||
|
||||
@checks = evaluate_selinux({ available => 1, runtime => 'Enforcing', configured => 'enforcing' });
|
||||
is((severity_of(\@checks, 'selinux.runtime'))[0], 'pass', 'selinux: enforcing passes');
|
||||
is((severity_of(\@checks, 'selinux.config'))[0], 'pass', 'selinux: matching config passes');
|
||||
@checks = evaluate_selinux({ available => 1, runtime => 'Permissive', configured => 'enforcing' });
|
||||
is((severity_of(\@checks, 'selinux.runtime'))[0], 'warn', 'selinux: permissive is a warning');
|
||||
is((severity_of(\@checks, 'selinux.config'))[0], 'info', 'selinux: a future enforcement is noted');
|
||||
@checks = evaluate_selinux({ available => 1, runtime => 'Enforcing', configured => 'disabled' });
|
||||
is((severity_of(\@checks, 'selinux.config'))[0], 'warn',
|
||||
'selinux: an enforcing runtime with a disabled config downgrades at boot');
|
||||
@checks = evaluate_selinux({ available => 1, runtime => 'Disabled', configured => 'enforcing' });
|
||||
is((severity_of(\@checks, 'selinux.config'))[0], 'warn',
|
||||
'selinux: a disabled runtime with an enforcing config is a contradiction, not a promise');
|
||||
@checks = evaluate_selinux({ available => 1, runtime => 'Enforcing', configured => '' });
|
||||
is((severity_of(\@checks, 'selinux.config'))[0], 'unknown',
|
||||
'selinux: no configuration file is unknown');
|
||||
@checks = evaluate_selinux({ available => 0, runtime => '', configured => '' });
|
||||
is(scalar @checks, 0, 'selinux: no tooling, no checks');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Updates
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(count_security_updates(<<'DNF4'), 2, 'updateinfo: two dnf 4 advisory lines');
|
||||
FEDORA-2026-aaaaaa security kernel-6.12.4-200.fc41.noarch
|
||||
FEDORA-2026-bbbbbb security/important openssl-3.2.0-1.fc41.x86_64
|
||||
DNF4
|
||||
is(count_security_updates("FEDORA-2026-cccccc bugfix bash-5.2.0-1.fc41.x86_64\n"), 0,
|
||||
'updateinfo: a bugfix line is not security');
|
||||
is(count_security_updates("Last metadata expiration check: 2:04:11 ago on Fri.\n"), 0,
|
||||
'updateinfo: a progress line is not an advisory');
|
||||
|
||||
is(parse_automatic_conf("[commands]\napply_updates = yes\n"), 'yes', 'automatic.conf: yes');
|
||||
is(parse_automatic_conf("[commands]\n# apply_updates = yes\napply_updates = no\n"), 'no',
|
||||
'automatic.conf: the last assignment, comments skipped');
|
||||
is(parse_automatic_conf("[commands]\nupgrade_type = security\n"), '', 'automatic.conf: the key is absent');
|
||||
|
||||
# On a dnf5 host dnf-automatic.timer is an alias whose target carries the
|
||||
# enablement, and "alias" itself names no state.
|
||||
is(join('|', pick_timer_unit({
|
||||
'dnf5-automatic.timer' => 'enabled',
|
||||
'dnf-automatic-install.timer' => 'not-found',
|
||||
'dnf-automatic.timer' => 'alias',
|
||||
})), 'dnf5-automatic.timer|enabled',
|
||||
'timers: an alias defers to the dnf5 unit name');
|
||||
is(join('|', pick_timer_unit({
|
||||
'dnf5-automatic.timer' => 'not-found',
|
||||
'dnf-automatic-install.timer' => 'disabled',
|
||||
'dnf-automatic.timer' => 'disabled',
|
||||
})), 'dnf-automatic-install.timer|disabled',
|
||||
'timers: the dnf4 install timer is still found');
|
||||
is(join('|', pick_timer_unit({
|
||||
'dnf5-automatic.timer' => 'not-found',
|
||||
'dnf-automatic-install.timer' => 'not-found',
|
||||
'dnf-automatic.timer' => 'alias',
|
||||
})), '|', 'timers: alias and not-found are no answer');
|
||||
|
||||
# An absent apply_updates is the documented default: no, download only.
|
||||
@checks = evaluate_updates({
|
||||
security_pending => 0, timer => 'enabled', timer_name => 'dnf5-automatic.timer',
|
||||
apply_updates => 'no', apply_updates_defaulted => 1,
|
||||
running_kernel => '6.12.4-200.fc44.x86_64', newest_kernel => '', reboot_required => 0,
|
||||
});
|
||||
is((severity_of(\@checks, 'updates.apply_updates'))[0], 'warn',
|
||||
'updates: the default downloads without installing');
|
||||
like((severity_of(\@checks, 'updates.apply_updates'))[1], qr/no \(the default\)/,
|
||||
'updates: a defaulted value says so');
|
||||
@checks = evaluate_updates({
|
||||
timer => 'unknown', timer_name => '', apply_updates => undef,
|
||||
security_pending => undef, pending_error => '', running_kernel => '',
|
||||
newest_kernel => '', reboot_required => undef,
|
||||
});
|
||||
is((severity_of(\@checks, 'updates.apply_updates'))[0], 'unknown',
|
||||
'updates: no readable configuration is unknown');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Accounts
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $users = parse_passwd([
|
||||
'root:x:0:0:root:/root:/bin/bash',
|
||||
'petrbalvin:x:1000:1000:Petr:/home/petrbalvin:/bin/zsh',
|
||||
'daemon:x:2:2:daemon:/sbin:/sbin/nologin',
|
||||
'brokenline',
|
||||
]);
|
||||
is(scalar @$users, 3, 'passwd: a malformed line is skipped');
|
||||
is($users->[0]{uid}, 0, 'passwd: the uid');
|
||||
|
||||
is(join(',', @{ empty_password_users(['root:', 'daemon:*', 'svc:!!']) }), 'root',
|
||||
'shadow: an empty hash, a locked one and a bang one');
|
||||
# A real shadow line carries the ageing fields behind the hash, so the hash is
|
||||
# the second field and not everything after the name.
|
||||
is(join(',', @{ empty_password_users([
|
||||
'svc::19997:0:99999:7:::',
|
||||
'daemon:*:19997:0:99999:7:::',
|
||||
'alice:$6$rounds=656000$ salted:19997:0:99999:7:::',
|
||||
'root:',
|
||||
]) }), 'svc,root', 'shadow: the empty hash is the second field, ageing fields aside');
|
||||
|
||||
my @principals = parse_sudoers_text(<<'SUDO');
|
||||
Defaults env_reset
|
||||
%wheel ALL=(ALL) ALL
|
||||
petrbalvin ALL=(ALL) NOPASSWD: ALL
|
||||
# %commented ALL=(ALL) NOPASSWD: ALL
|
||||
SUDO
|
||||
is(join('|', @principals), 'petrbalvin', 'sudoers: the NOPASSWD principal, comments skipped');
|
||||
|
||||
@checks = evaluate_accounts({
|
||||
uid_zero => ['root'], empty_passwords => undef, nopasswd => undef,
|
||||
human_users => ['petrbalvin (1000)'], root_authorized_keys => undef,
|
||||
});
|
||||
is((severity_of(\@checks, 'accounts.uid_zero'))[0], 'pass', 'accounts: only root at uid 0');
|
||||
is((severity_of(\@checks, 'accounts.empty_passwords'))[0], 'unknown',
|
||||
'accounts: shadow unreadable is unknown, not a pass');
|
||||
@checks = evaluate_accounts({
|
||||
uid_zero => ['root', 'toor'], empty_passwords => ['svc'], nopasswd => ['%wheel'],
|
||||
human_users => [], root_authorized_keys => 2,
|
||||
});
|
||||
is((severity_of(\@checks, 'accounts.uid_zero'))[0], 'critical', 'accounts: a second uid 0 is critical');
|
||||
is((severity_of(\@checks, 'accounts.empty_passwords'))[0], 'critical', 'accounts: an empty password is critical');
|
||||
is((severity_of(\@checks, 'accounts.nopasswd_sudo'))[0], 'warn', 'accounts: NOPASSWD is a warning');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Services and the kernel sysctls
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is((severity_of([evaluate_services([])], 'services.failed_units'))[0], 'pass', 'services: none failed');
|
||||
is((severity_of([evaluate_services([{ unit => 'sshd.service', state => 'failed' }])],
|
||||
'services.failed_units'))[0], 'warn', 'services: a failed unit is a warning');
|
||||
is((severity_of([evaluate_services(undef)], 'services.failed_units'))[0], 'unknown',
|
||||
'services: no systemctl is unknown');
|
||||
|
||||
# The columns of `systemctl --failed --no-legend --plain` are unit, load,
|
||||
# active, sub, description: the report names the active state.
|
||||
my $failed_units = parse_failed_units(
|
||||
"sshd.service loaded failed failed OpenSSH server daemon\n" .
|
||||
"dnf5-automatic.service not-found failed failed (bad unit)\n");
|
||||
is(scalar @$failed_units, 2, 'services: two failed lines parse');
|
||||
is($failed_units->[0]{state}, 'failed', 'services: the state is the active column, not the load');
|
||||
is($failed_units->[1]{unit}, 'dnf5-automatic.service', 'services: a not-found load state still parses');
|
||||
|
||||
my %sysctl_ok = (
|
||||
'/proc/sys/kernel/kptr_restrict' => '1',
|
||||
'/proc/sys/kernel/dmesg_restrict' => '1',
|
||||
'/proc/sys/kernel/unprivileged_bpf_disabled' => '2',
|
||||
'/proc/sys/kernel/yama/ptrace_scope' => '1',
|
||||
'/proc/sys/fs/protected_symlinks' => '1',
|
||||
'/proc/sys/fs/protected_hardlinks' => '1',
|
||||
'/proc/sys/fs/protected_fifos' => '1',
|
||||
'/proc/sys/fs/protected_regular' => '2',
|
||||
'/proc/sys/net/ipv4/tcp_syncookies' => '1',
|
||||
'/proc/sys/kernel/randomize_va_space' => '2',
|
||||
);
|
||||
@checks = evaluate_kernel({ %sysctl_ok });
|
||||
my $pass_count = grep { $_->{severity} eq 'pass' } @checks;
|
||||
is($pass_count, 7, 'kernel: a hardened machine passes every check');
|
||||
|
||||
my %sysctl_weak = (%sysctl_ok,
|
||||
'/proc/sys/kernel/kptr_restrict' => '0',
|
||||
'/proc/sys/kernel/randomize_va_space' => '1',
|
||||
);
|
||||
delete $sysctl_weak{'/proc/sys/kernel/yama/ptrace_scope'};
|
||||
@checks = evaluate_kernel({ %sysctl_weak });
|
||||
is((severity_of(\@checks, 'kernel.kptr_restrict'))[0], 'warn', 'kernel: a visible kptr is a warning');
|
||||
is((severity_of(\@checks, 'kernel.randomize_va_space'))[0], 'warn', 'kernel: reduced ASLR is a warning');
|
||||
is((severity_of(\@checks, 'kernel.yama_ptrace_scope'))[0], 'unknown', 'kernel: an absent sysctl is unknown');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# The deep scan evaluator
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@checks = evaluate_files({
|
||||
suid => ['/usr/bin/sudo', '/tmp/backdoor'],
|
||||
world_writable_files => ['/var/tmp/junk'],
|
||||
world_writable_dirs => [],
|
||||
unowned => [],
|
||||
});
|
||||
is((severity_of(\@checks, 'files.suid_staging'))[0], 'critical',
|
||||
'files: a SUID binary under /tmp is critical');
|
||||
like((severity_of(\@checks, 'files.world_writable'))[1], qr/1 world writable file/,
|
||||
'files: the world writable count');
|
||||
|
||||
@checks = evaluate_files({
|
||||
suid => ['/usr/bin/sudo'],
|
||||
world_writable_files => [], world_writable_dirs => [], unowned => [],
|
||||
});
|
||||
is((severity_of(\@checks, 'files.suid_staging'))[0], 'pass', 'files: a clean staging check');
|
||||
is((severity_of(\@checks, 'files.unowned'))[0], 'pass', 'files: nothing unowned');
|
||||
|
||||
@checks = evaluate_files({
|
||||
suid => [], world_writable_files => [], world_writable_dirs => ['/tmp'], unowned => ['x'],
|
||||
});
|
||||
is((severity_of(\@checks, 'files.world_writable'))[0], 'warn',
|
||||
'files: a stickyless world writable directory is a warning');
|
||||
is((severity_of(\@checks, 'files.unowned'))[0], 'warn', 'files: an unowned file is a warning');
|
||||
|
||||
# A scan that did not complete is unknown, never a clean pass: an interrupted
|
||||
# find leaves an undef slot behind.
|
||||
@checks = evaluate_files({
|
||||
suid => undef, world_writable_files => [], world_writable_dirs => [], unowned => [],
|
||||
});
|
||||
is((severity_of(\@checks, 'files.suid_staging'))[0], 'unknown',
|
||||
'files: an interrupted SUID scan is unknown');
|
||||
@checks = evaluate_files({
|
||||
suid => [], world_writable_files => undef, world_writable_dirs => [], unowned => [],
|
||||
});
|
||||
is((severity_of(\@checks, 'files.world_writable'))[0], 'unknown',
|
||||
'files: an interrupted world writable scan is unknown');
|
||||
@checks = evaluate_files({
|
||||
suid => [], world_writable_files => [], world_writable_dirs => [], unowned => undef,
|
||||
});
|
||||
is((severity_of(\@checks, 'files.unowned'))[0], 'unknown',
|
||||
'files: an interrupted unowned scan is unknown');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Grade and findings
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $grade = compute_grade({});
|
||||
is($grade->{grade}, 'N/A', 'grade: nothing assessable is not graded');
|
||||
is($grade->{score}, undef, 'grade: no score');
|
||||
|
||||
my %by_id;
|
||||
$by_id{"s.$_"} = {
|
||||
id => "s.$_",
|
||||
section => 's',
|
||||
severity => $_ eq 'a' ? 'pass' : $_ eq 'b' ? 'warn' : $_ eq 'c' ? 'critical' : 'unknown',
|
||||
weight => $_ eq 'd' ? 0 : 8,
|
||||
} for qw(a b c d e);
|
||||
$grade = compute_grade({ %by_id });
|
||||
# a: 8, b: 4, c: 0, d: weight 0 so not counted, e: unknown so out of the pool.
|
||||
is($grade->{maxima}{d}, undef, 'grade: a weightless check is not in the maxima');
|
||||
is($grade->{score}, 50, 'grade: 12 of the 24 remaining points');
|
||||
is($grade->{grade}, 'F', 'grade: the letter follows the thresholds');
|
||||
is($grade->{sections}{s}{possible}, 24, 'grade: the unknown check leaves the pool');
|
||||
is($grade->{skipped}{'s.e'}, 1, 'grade: the unknown check is named as skipped');
|
||||
|
||||
%by_id = map {
|
||||
("sec.$_" => { id => "sec.$_", section => 'sec', severity => 'pass', weight => 10 });
|
||||
} qw(one two);
|
||||
$grade = compute_grade({ %by_id });
|
||||
is($grade->{score}, 100, 'grade: full marks');
|
||||
|
||||
my $findings = findings_of(\%by_id);
|
||||
is(scalar @$findings, 0, 'findings: a clean set is empty');
|
||||
|
||||
%by_id = (
|
||||
'a.w' => { id => 'a.w', section => 'a', severity => 'warn', weight => 4, message => 'w' },
|
||||
'a.c' => { id => 'a.c', section => 'a', severity => 'critical', weight => 4, message => 'c' },
|
||||
'b.w' => { id => 'b.w', section => 'b', severity => 'warn', weight => 4, message => 'w2' },
|
||||
'a.p' => { id => 'a.p', section => 'a', severity => 'pass', weight => 4, message => 'p' },
|
||||
);
|
||||
$findings = findings_of(\%by_id);
|
||||
is(join(',', map { $_->{id} } @$findings), 'a.c,a.w,b.w',
|
||||
'findings: criticals first, then warnings by id, passes left out');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# JSON
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
like(json_encode({ root => 1, deep => 0 }), qr/"root": true/, 'json: a listed boolean path');
|
||||
like(json_encode({ sections => { firewall => { listeners => [ { loopback => 1, exposed => 0 } ] } } }),
|
||||
qr/"loopback": true/, 'json: a listener boolean by shape');
|
||||
like(json_encode({ sections => { ssh => { available => 1 }, selinux => { available => 0 } } }),
|
||||
qr/"available": true/, 'json: the section available flags are booleans');
|
||||
like(json_encode({ sections => { firewall => { listeners => [ { allowed => 1 } ] } } }),
|
||||
qr/"allowed": true/, 'json: a listener allowed flag is a boolean');
|
||||
like(json_encode({ a => 'text', b => 3 }), qr/"b": 3/, 'json: a number stays a number');
|
||||
like(json_encode({ s => "quote\"end\ning" }), qr/"quote\\"end\\ning"/, 'json: the escapes');
|
||||
like(json_encode({}), qr/\{\}/, 'json: an empty object');
|
||||
like(json_encode([]), qr/\[\]/, 'json: an empty array');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Arguments
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my @saved = @ARGV;
|
||||
@ARGV = ('--json', '--strict', '--deep', '--section', 'ssh,firewall');
|
||||
my %args = parse_args();
|
||||
is($args{json}, 1, 'args: --json');
|
||||
is($args{strict}, 1, 'args: --strict');
|
||||
is($args{deep}, 1, 'args: --deep');
|
||||
is($args{section}, 'ssh,firewall', 'args: --section takes a list');
|
||||
@ARGV = ('--section=ssh');
|
||||
%args = parse_args();
|
||||
is($args{section}, 'ssh', 'args: --section=VALUE');
|
||||
@ARGV = ();
|
||||
%args = parse_args();
|
||||
is($args{deep}, 0, 'args: deep is off by default');
|
||||
@ARGV = @saved;
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Section selection and the exit status of the program
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my ($resolved, $section_error) = resolve_sections('ssh,firewall', 0);
|
||||
is(join(',', @$resolved), 'ssh,firewall', 'sections: a plain list resolves');
|
||||
is($section_error, undef, 'sections: no error for a plain list');
|
||||
($resolved, $section_error) = resolve_sections('ssh,ssh', 0);
|
||||
is(join(',', @$resolved), 'ssh', 'sections: a repeated name runs once');
|
||||
($resolved, $section_error) = resolve_sections('ssh', 1);
|
||||
is(join(',', @$resolved), 'ssh,files', 'sections: --deep adds the file scan');
|
||||
($resolved, $section_error) = resolve_sections('', 0);
|
||||
is(scalar @$resolved, 7, 'sections: the default run is every section but files');
|
||||
($resolved, $section_error) = resolve_sections('nope', 0);
|
||||
is($resolved, undef, 'sections: an unknown name yields no list');
|
||||
like($section_error, qr/unknown section/, 'sections: an unknown name is reported');
|
||||
($resolved, $section_error) = resolve_sections('files', 0);
|
||||
like($section_error, qr/requires --deep/, 'sections: files without --deep is refused');
|
||||
|
||||
# The validation runs before any collection, and a usage error exits 2 as the
|
||||
# usage text promises, not 1.
|
||||
my $exit_code = system($^X, "$root/security-audit.pl", '--section', 'nope') >> 8;
|
||||
is($exit_code, 2, 'cli: an unknown section is a usage error, exit 2');
|
||||
$exit_code = system($^X, "$root/security-audit.pl", '--section', 'files') >> 8;
|
||||
is($exit_code, 2, 'cli: files without --deep is a usage error, exit 2');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
unlink("$tmp_dir/sshd_config", "$tmp_dir/50-audit.conf");
|
||||
rmdir($tmp_dir);
|
||||
|
||||
print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
@@ -0,0 +1,200 @@
|
||||
#!/usr/bin/env perl
|
||||
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||||
# SPDX-License-Identifier: MIT
|
||||
|
||||
# Checks for server-setup.pl: the dnf-automatic configuration renderer, the os-release
|
||||
# reader, the error text, the argument parsing, the command runner's wait-status
|
||||
# conversion and the EPEL enable path.
|
||||
#
|
||||
# Run from anywhere: perl tests/server-setup.pl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
|
||||
$root = "./$root" if $root !~ m{^/};
|
||||
require "$root/server-setup.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 like {
|
||||
my ($got, $re, $label) = @_;
|
||||
my $matched = (defined $got && $got =~ $re) ? 1 : 0;
|
||||
if ($matched) {
|
||||
$passed++;
|
||||
print "ok $label\n";
|
||||
return 1;
|
||||
}
|
||||
$failed++;
|
||||
print "FAIL $label\n got: " . (defined $got ? $got : 'undef') . "\n want: $re\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# dnf-automatic configuration
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# The renderer returns the lines and whether it changed anything, which is how its
|
||||
# caller decides whether to write.
|
||||
my @order = qw(upgrade_type apply_updates);
|
||||
my ($rendered, $changed) = render_dnf_automatic_conf(
|
||||
["[commands]\n", "# a comment\n", "upgrade_type = security\n"],
|
||||
\@order,
|
||||
{ upgrade_type => 'default', apply_updates => 'yes' },
|
||||
);
|
||||
my $text = join('', @$rendered);
|
||||
is($changed, 1, 'dnf-automatic: a change is reported');
|
||||
like($text, qr/^\[commands\]$/m, 'dnf-automatic: the section survives');
|
||||
like($text, qr/^upgrade_type = default$/m, 'dnf-automatic: an existing key is updated');
|
||||
like($text, qr/^apply_updates = yes$/m, 'dnf-automatic: a missing key is added');
|
||||
like($text, qr/^# a comment$/m, 'dnf-automatic: a comment survives');
|
||||
is(($text =~ /upgrade_type/g) + 0, 1, 'dnf-automatic: the key is written once');
|
||||
|
||||
my ($again, $unchanged) = render_dnf_automatic_conf($rendered, \@order,
|
||||
{ upgrade_type => 'default', apply_updates => 'yes' });
|
||||
is($unchanged, 0, 'dnf-automatic: an already correct file is reported unchanged');
|
||||
is(join('', @$again), $text, 'dnf-automatic: an already correct file is reproduced exactly');
|
||||
|
||||
my ($fresh, $fresh_changed) = render_dnf_automatic_conf([], \@order, { upgrade_type => 'default' });
|
||||
check(join('', @$fresh) !~ /^apply_updates = *$/m,
|
||||
'dnf-automatic: a key with no desired value is not written empty');
|
||||
my $fresh_text = join('', @$fresh);
|
||||
is($fresh_changed, 1, 'dnf-automatic: a missing section is a change');
|
||||
like($fresh_text, qr/^\[commands\]$/m, 'dnf-automatic: a missing section is created');
|
||||
like($fresh_text, qr/^upgrade_type = default$/m, 'dnf-automatic: the key lands in it');
|
||||
|
||||
my ($unterminated, $unterminated_changed) = render_dnf_automatic_conf(
|
||||
["[commands]\n", 'upgrade_type = security'],
|
||||
\@order,
|
||||
{ apply_updates => 'yes' },
|
||||
);
|
||||
my $unterminated_text = join('', @$unterminated);
|
||||
is($unterminated_changed, 1, 'dnf-automatic: an appended key is a change');
|
||||
like($unterminated_text, qr/^apply_updates = yes$/m,
|
||||
'dnf-automatic: an unterminated last line does not swallow the new key');
|
||||
check($unterminated_text !~ /securityapply_updates/,
|
||||
'dnf-automatic: no key is glued onto another');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# os-release and error text
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $release = parse_os_release();
|
||||
is(ref($release), 'HASH', 'os-release: a hash reference');
|
||||
check(defined $release->{ID} && length $release->{ID}, 'os-release: the identifier is read');
|
||||
check(defined $release->{VERSION_ID}, 'os-release: the version is read');
|
||||
|
||||
my $handle;
|
||||
open($handle, '<', '/nonexistent/for-the-test');
|
||||
my $error = os_error_text('/nonexistent/for-the-test');
|
||||
like($error, qr/^\[Errno \d+\] .+: '\/nonexistent\/for-the-test'$/,
|
||||
'error text: the errno, the reason and the path');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Arguments
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my @saved = @ARGV;
|
||||
@ARGV = ('--dry-run', '--skip-firewall');
|
||||
my %args = parse_args();
|
||||
is($args{dry_run}, 1, 'args: --dry-run');
|
||||
is($args{skip_firewall}, 1, 'args: --skip-firewall');
|
||||
is($args{skip_packages}, 0, 'args: an unset skip stays off');
|
||||
@ARGV = ();
|
||||
my %defaults = parse_args();
|
||||
is($defaults{dry_run}, 0, 'args: dry run is off by default');
|
||||
@ARGV = @saved;
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# The command runner
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(wait_status_rc(0), 0, 'runner: a clean exit is rc 0');
|
||||
is(wait_status_rc(2 << 8), 2, 'runner: the exit status is taken from bits 8-15');
|
||||
is(wait_status_rc(9), 137, 'runner: a child killed by SIGKILL is not read as rc 0');
|
||||
is(wait_status_rc(11), 139, 'runner: a child killed by a signal is never rc 0');
|
||||
|
||||
my $killed = run(['sh', '-c', 'kill -9 $$']);
|
||||
is($killed->{rc}, 137, 'runner: run reports 128+signal for a killed child');
|
||||
my $exited = run(['sh', '-c', 'exit 3']);
|
||||
is($exited->{rc}, 3, 'runner: run reports the exit code of a child');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# EPEL: a present package with a disabled repository must be enabled, and a
|
||||
# silent no-op must not be reported as success
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
{
|
||||
no warnings 'redefine';
|
||||
my ($epel_enabled, $enable_works, @seen);
|
||||
|
||||
my $fake_run = sub {
|
||||
my ($cmd) = @_;
|
||||
my $line = join ' ', @$cmd;
|
||||
push @seen, $line;
|
||||
if ($line eq 'dnf repolist --enabled') {
|
||||
my $out = "repo id\trepo name\n";
|
||||
$out .= "epel\tExtra Packages for Enterprise Linux\n" if $epel_enabled;
|
||||
return { rc => 0, out => $out, err => '' };
|
||||
}
|
||||
return { rc => 0, out => "epel-release-10-0.noarch\n", err => '' }
|
||||
if $line eq 'rpm -q epel-release';
|
||||
return { rc => 0, out => '', err => '' }
|
||||
if $line eq 'dnf config-manager --set-enabled crb';
|
||||
if ($line eq 'dnf config-manager --set-enabled epel') {
|
||||
if ($enable_works) {
|
||||
$epel_enabled = 1;
|
||||
return { rc => 0, out => '', err => '' };
|
||||
}
|
||||
return { rc => 1, out => '', err => 'failed' };
|
||||
}
|
||||
# Installing an already-present package is a successful no-op that
|
||||
# leaves the repository switched off, which made the old path a false
|
||||
# success.
|
||||
return { rc => 0, out => '', err => '' }
|
||||
if $line eq 'dnf install -y epel-release';
|
||||
return { rc => 1, out => '', err => "unexpected command: $line" };
|
||||
};
|
||||
|
||||
local *run = $fake_run;
|
||||
|
||||
($epel_enabled, $enable_works, @seen) = (0, 1);
|
||||
my $ok_info = ensure_epel(0);
|
||||
check(!$ok_info->{failed} && $epel_enabled,
|
||||
'EPEL: a disabled repository is enabled when config-manager works');
|
||||
check($ok_info->{installed}, 'EPEL: success is reported once the repository is enabled');
|
||||
check((grep { /install / } @seen) == 0,
|
||||
'EPEL: an installed package is enabled, not installed again');
|
||||
|
||||
($epel_enabled, $enable_works, @seen) = (0, 0);
|
||||
my $fail_info = ensure_epel(0);
|
||||
check($fail_info->{failed} && !$epel_enabled,
|
||||
'EPEL: a repository that stays disabled is a failure, not a success');
|
||||
|
||||
($epel_enabled, $enable_works, @seen) = (0, 1);
|
||||
ensure_epel(1);
|
||||
check((grep { /set-enabled|install / } @seen) == 0,
|
||||
'EPEL: a dry run issues no mutating command');
|
||||
}
|
||||
|
||||
print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
@@ -0,0 +1,268 @@
|
||||
#!/usr/bin/perl
|
||||
# Unit checks for sglang-deploy.pl: the pure helpers, against what they must produce.
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
|
||||
$root = "./$root" if $root !~ m{^/};
|
||||
require "$root/sglang-deploy.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);
|
||||
}
|
||||
|
||||
# The verdict of a match is forced into a boolean: in a sub argument list a failed match
|
||||
# yields the empty list, which shifts the label into the condition slot and turns the
|
||||
# failure into a silent pass.
|
||||
sub like {
|
||||
my ($got, $re, $label) = @_;
|
||||
$label = 'like without a label' unless defined $label;
|
||||
my $matched = (defined $got && $got =~ $re) ? 1 : 0;
|
||||
return is($matched, 1, $label);
|
||||
}
|
||||
|
||||
sub check_unlike {
|
||||
my ($got, $re, $label) = @_;
|
||||
$label = 'check_unlike without a label' unless defined $label;
|
||||
my $matched = (defined $got && $got !~ $re) ? 1 : 0;
|
||||
return is($matched, 1, $label);
|
||||
}
|
||||
|
||||
# ---- version_cmp ----------------------------------------------------------
|
||||
is(version_cmp('7.2.4', '7.2.0'), 1, 'version_cmp 7.2.4 > 7.2.0');
|
||||
is(version_cmp('7.2.0', '7.2.4'), -1, 'version_cmp 7.2.0 < 7.2.4');
|
||||
is(version_cmp('7.2', '7.2.0'), 0, 'version_cmp 7.2 == 7.2.0');
|
||||
is(version_cmp('10.0.0', '7.2.4'), 1, 'version_cmp 10.0.0 > 7.2.4');
|
||||
is(version_cmp('6.4.3', '7.0.0'), -1, 'version_cmp 6.4.3 < 7.0.0');
|
||||
is(version_cmp('7.10.0', '7.9.0'), 1, 'version_cmp 7.10.0 > 7.9.0 (numeric, not lexical)');
|
||||
|
||||
# ---- select_rocm_flavour --------------------------------------------------
|
||||
is(select_rocm_flavour('7.2.4'), 'rocm724', 'flavour: host 7.2.4');
|
||||
is(select_rocm_flavour('7.2.5'), 'rocm724', 'flavour: host 7.2.5');
|
||||
is(select_rocm_flavour('7.2.3'), 'rocm720', 'flavour: host 7.2.3');
|
||||
is(select_rocm_flavour('7.2.0'), 'rocm720', 'flavour: host 7.2.0');
|
||||
is(select_rocm_flavour('7.1.0'), 'rocm700', 'flavour: host 7.1.0 falls back to rocm700');
|
||||
is(select_rocm_flavour('7.0.0'), 'rocm700', 'flavour: host 7.0.0');
|
||||
is(select_rocm_flavour('10.0.0'), 'rocm10', 'flavour: host 10.0.0');
|
||||
is(select_rocm_flavour('10.2.0'), 'rocm10', 'flavour: host 10.2.0');
|
||||
is(select_rocm_flavour('6.4.0'), undef, 'flavour: host 6.4.0 has no image');
|
||||
|
||||
# ---- arch_variant / radeon_present ---------------------------------------
|
||||
my @mi300 = ('Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI300X OAM [1002:74a1] (rev 01)');
|
||||
my @mi325 = ('Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI325X [1002:74a1]');
|
||||
my @mi350 = ('Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI350X [1002:75a0]');
|
||||
my @mi355 = ('Advanced Micro Devices, Inc. [AMD/ATI] Instinct MI355X [1002:75a3]');
|
||||
my @radeon = ('Advanced Micro Devices, Inc. [AMD/ATI] Navi 31 [Radeon RX 7900 XTX] [1002:744c]');
|
||||
my @strix = ('Advanced Micro Devices, Inc. [AMD/ATI] Strix Halo [Radeon 8060S] [1002:150e]');
|
||||
is(arch_variant(\@mi300), 'mi30x', 'arch: MI300X -> mi30x');
|
||||
is(arch_variant(\@mi325), 'mi30x', 'arch: MI325X -> mi30x');
|
||||
is(arch_variant(\@mi350), 'mi35x', 'arch: MI350X -> mi35x');
|
||||
is(arch_variant(\@mi355), 'mi35x', 'arch: MI355X -> mi35x');
|
||||
is(arch_variant(\@radeon), undef, 'arch: Radeon has no published image');
|
||||
is(arch_variant(\@strix), 'gfx1151', 'arch: Strix Halo maps to gfx1151');
|
||||
is(radeon_present(\@radeon), 1, 'radeon: Navi 31 detected');
|
||||
is(radeon_present(\@strix), 0, 'radeon: Strix Halo is served by AMD builds');
|
||||
is(radeon_present(\@mi300), 0, 'radeon: MI300X is not a Radeon card');
|
||||
|
||||
# ---- resolve_image / model_display ---------------------------------------
|
||||
is(resolve_image('docker.io/lmsysorg/sglang', 'v0.5.19', 'mi30x', 'rocm10'),
|
||||
'docker.io/lmsysorg/sglang:v0.5.19-rocm10-mi30x', 'image: resolved tag');
|
||||
is(resolve_image('docker.io/rocm/sgl-dev', 'v0.5.19', 'gfx1151', 'rocm724'),
|
||||
'docker.io/rocm/sgl-dev:v0.5.19-rocm724-gfx1151', 'image: AMD dev repository for gfx1151');
|
||||
is(model_display('ZhipuAI/GLM-5.3'), 'GLM 5.3', 'display: known model');
|
||||
is(model_display('acme/unknown'), 'acme/unknown', 'display: unknown model passes through');
|
||||
|
||||
# ---- the preset catalogue ------------------------------------------------
|
||||
# The menu is the owner's list in the owner's order, so the names are asserted
|
||||
# one by one, and each display name must resolve to the exact ModelScope
|
||||
# repository the engine will pull weights from.
|
||||
is(join('|', default_model_order()),
|
||||
'GLM 5.3|GLM 5.3 Flash|Qwen 3.8 Max|Qwen 3.8 Flash|DeepSeek V4.1 Flash',
|
||||
'presets: the menu order');
|
||||
is(model_display('ZhipuAI/GLM-5.3'), 'GLM 5.3', 'presets: GLM 5.3');
|
||||
is(default_model_repo('GLM 5.3'), 'ZhipuAI/GLM-5.3', 'presets: GLM 5.3 on ModelScope');
|
||||
is(default_model_repo('GLM 5.3 Flash'), 'ZhipuAI/GLM-5.3-Flash',
|
||||
'presets: GLM 5.3 Flash on ModelScope, under ZhipuAI');
|
||||
is(default_model_repo('Qwen 3.8 Max'), 'Qwen/Qwen3.8-2.4T-A95B',
|
||||
'presets: Qwen 3.8 Max under its weight name');
|
||||
is(default_model_repo('Qwen 3.8 Flash'), 'Qwen/Qwen3.8-Flash-Next',
|
||||
'presets: Qwen 3.8 Flash under its weight name');
|
||||
is(default_model_repo('DeepSeek V4.1 Flash'), 'deepseek-ai/DeepSeek-V4.1-Flash',
|
||||
'presets: DeepSeek V4.1 Flash');
|
||||
is(model_display('Qwen/Qwen3.8-2.4T-A95B'), 'Qwen 3.8 Max',
|
||||
'display: the reverse lookup through a weight name');
|
||||
for my $id (map { default_model_repo($_) } default_model_order()) {
|
||||
like($id, qr{^[A-Za-z0-9._-]+/[A-Za-z0-9._-]+$}, "presets: $id fits the model ID pattern");
|
||||
}
|
||||
|
||||
# ---- base64url and key shape ---------------------------------------------
|
||||
is(encode_base64url('Man'), 'TWFu', 'base64url: Man -> TWFu');
|
||||
is(encode_base64url("\xfb\xff"), '-_8', 'base64url: FB FF -> -_8 (url alphabet)');
|
||||
is(encode_base64url('M'), 'TQ', 'base64url: one byte, no padding');
|
||||
my $key = generate_api_key();
|
||||
like($key, qr/^[A-Za-z0-9_-]{43}$/, 'key: 32 bytes -> 43 url-safe characters');
|
||||
my $key2 = generate_api_key();
|
||||
is($key eq $key2 ? 'same' : 'different', 'different', 'key: two calls differ');
|
||||
|
||||
# ---- is_number ------------------------------------------------------------
|
||||
is((is_number('8000') ? 1 : 0), 1, 'is_number: 8000');
|
||||
is((is_number('0.90') ? 1 : 0), 1, 'is_number: 0.90');
|
||||
is((is_number('abc') ? 1 : 0), 0, 'is_number: abc');
|
||||
is((is_number('') ? 1 : 0), 0, 'is_number: empty');
|
||||
|
||||
# ---- is_positive_int / valid_dir_path -------------------------------------
|
||||
is((is_positive_int('4') ? 1 : 0), 1, 'is_positive_int: 4');
|
||||
is((is_positive_int('0') ? 1 : 0), 0, 'is_positive_int: 0 is not positive');
|
||||
is((is_positive_int('8000.5') ? 1 : 0), 0, 'is_positive_int: a fractional port is refused');
|
||||
is((is_positive_int('1e2') ? 1 : 0), 0, 'is_positive_int: an exponent is refused');
|
||||
is((valid_dir_path('/opt/sglang') ? 1 : 0), 1, 'valid_dir_path: an absolute path passes');
|
||||
is((valid_dir_path('sglang') ? 1 : 0), 0, 'valid_dir_path: a relative path is refused');
|
||||
is((valid_dir_path('/opt/sg lang') ? 1 : 0), 0, 'valid_dir_path: whitespace is refused');
|
||||
is((valid_dir_path('/opt/%h/sglang') ? 1 : 0), 0,
|
||||
'valid_dir_path: a systemd specifier is refused');
|
||||
is((valid_dir_path('/opt/x;/sglang') ? 1 : 0), 0,
|
||||
'valid_dir_path: an nginx directive end is refused');
|
||||
|
||||
# ---- run(): exit status, signals and timeout ------------------------------
|
||||
my $killed = run([$^X, '-e', 'kill 9, $$']);
|
||||
is($killed->{rc}, 137, 'run: a child killed by a signal reports 128+signal, not 0');
|
||||
my $exited = run([$^X, '-e', 'exit 3']);
|
||||
is($exited->{rc}, 3, 'run: the child exit code passes through');
|
||||
my $timedout = run([$^X, '-e', 'sleep 5'], timeout => 1);
|
||||
is($timedout->{rc}, 124, 'run: an expired timeout reports rc 124');
|
||||
|
||||
# ---- family_is_fatal: --image overrides the GPU family --------------------
|
||||
is(family_is_fatal(undef, 0), 1, 'family: an unmatched card without --image is fatal');
|
||||
is(family_is_fatal(undef, 1), 0, 'family: --image overrides an unmatched card');
|
||||
is(family_is_fatal('mi30x', 0), 0, 'family: a published family is never fatal');
|
||||
|
||||
# ---- radeon_env_for: the family decides, not any Radeon -------------------
|
||||
my @mixed = ('Instinct MI300X [1002:74a1]', 'Navi 31 [Radeon RX 7900 XTX] [1002:744c]');
|
||||
is(arch_variant(\@mixed), 'mi30x', 'env: a mixed host resolves the Instinct family');
|
||||
is(radeon_present(\@mixed), 1, 'env: a mixed host does carry a Radeon');
|
||||
is(scalar @{ radeon_env_for(arch_variant(\@mixed), radeon_present(\@mixed)) }, 0,
|
||||
'env: a display Radeon does not switch an Instinct deployment to the Radeon defaults');
|
||||
is(scalar @{ radeon_env_for('gfx1151', 0) }, 2, 'env: gfx1151 carries the Radeon defaults');
|
||||
is(scalar @{ radeon_env_for(undef, 1) }, 2,
|
||||
'env: a custom image on a Radeon-only host carries the Radeon defaults');
|
||||
is(scalar @{ radeon_env_for('mi30x', 0) }, 0, 'env: an Instinct host carries none');
|
||||
|
||||
# ---- nginx config --------------------------------------------------------
|
||||
my $conf = nginx_conf_content(8000, '[::1]', '/etc/ssl/sglang');
|
||||
like($conf, qr/listen \[::\]:443 ssl;/, 'nginx: IPv6 listener on a dual-stack kernel');
|
||||
like($conf, qr/listen 443 ssl;/, 'nginx: IPv4 listener');
|
||||
like($conf, qr|ssl_certificate /etc/ssl/sglang/sglang\.crt;|, 'nginx: certificate path');
|
||||
like($conf, qr/ssl_certificate_key \/etc\/ssl\/sglang\/sglang\.key;/, 'nginx: key path');
|
||||
like($conf, qr|proxy_pass http://\[::1\]:8000;|, 'nginx: loopback upstream with the port');
|
||||
like($conf, qr/proxy_http_version 1\.1;/, 'nginx: HTTP/1.1 for streaming');
|
||||
like($conf, qr/proxy_buffering off;/, 'nginx: buffering off for streaming');
|
||||
like($conf, qr/proxy_set_header Host \$host;/, 'nginx: $host survives the heredoc');
|
||||
like($conf, qr/proxy_set_header X-Forwarded-For \$proxy_add_x_forwarded_for;/,
|
||||
'nginx: $proxy_add_x_forwarded_for survives the heredoc');
|
||||
|
||||
my $conf4 = nginx_conf_content(8000, '127.0.0.1', '/etc/ssl/sglang');
|
||||
is($conf4 =~ /\[::\]/ ? 'yes' : 'no',
|
||||
(-e '/proc/net/if_inet6' ? 'yes' : 'no'), 'nginx: IPv6 listener follows the kernel');
|
||||
|
||||
# ---- systemd unit --------------------------------------------------------
|
||||
my $unit = systemd_content({
|
||||
model => 'ZhipuAI/GLM-5.3',
|
||||
host => '::1',
|
||||
port => 8000,
|
||||
tensor_parallel => 4,
|
||||
max_model_len => 32768,
|
||||
gpu_memory_utilization => '0.9',
|
||||
state_dir => '/opt/sglang',
|
||||
image => 'docker.io/lmsysorg/sglang:v0.5.19-rocm10-mi30x',
|
||||
env_file => '/etc/sysconfig/sglang',
|
||||
radeon_env => [],
|
||||
});
|
||||
like($unit, qr/Description=SGLang Inference Server \(ZhipuAI\/GLM-5\.3\)/, 'unit: description');
|
||||
like($unit, qr/EnvironmentFile=\/etc\/sysconfig\/sglang/, 'unit: EnvironmentFile');
|
||||
like($unit, qr/Environment=SGLANG_USE_MODELSCOPE=true/, 'unit: weights come from ModelScope');
|
||||
like($unit, qr/--network=host/, 'unit: host networking');
|
||||
like($unit, qr/--device=\/dev\/kfd --device=\/dev\/dri/, 'unit: GPU device nodes');
|
||||
like($unit, qr/--group-add video/, 'unit: video group');
|
||||
like($unit, qr/--ipc=host/, 'unit: IPC namespace');
|
||||
like($unit, qr/--cap-add=SYS_PTRACE/, 'unit: ptrace capability');
|
||||
like($unit, qr/--security-opt seccomp=unconfined/, 'unit: seccomp');
|
||||
like($unit, qr|--volume /opt/sglang/modelscope:/root/\.cache/modelscope:Z|,
|
||||
'unit: ModelScope cache volume with SELinux relabel');
|
||||
like($unit, qr/--env MODELSCOPE_TOKEN/, 'unit: ModelScope token forwarded when set');
|
||||
like($unit, qr/--rm --replace --name sglang/, 'unit: container name and cleanup');
|
||||
like($unit, qr/--pull=missing/, 'unit: pull policy');
|
||||
like($unit, qr/docker\.io\/lmsysorg\/sglang:v0\.5\.19-rocm10-mi30x/, 'unit: image');
|
||||
like($unit, qr/python3 -m sglang\.launch_server/, 'unit: engine entry point');
|
||||
like($unit, qr/--model-path ZhipuAI\/GLM-5\.3/, 'unit: model path');
|
||||
like($unit, qr/--host ::1/, 'unit: loopback bind');
|
||||
like($unit, qr/--port 8000/, 'unit: port');
|
||||
like($unit, qr/--api-key \$\{SGLANG_API_KEY\}/, 'unit: API key from the environment file');
|
||||
is($unit =~ /sk-[A-Za-z0-9]/ ? 'yes' : 'no', 'no', 'unit: no literal API key');
|
||||
like($unit, qr/--tp-size 4/, 'unit: tensor parallel as --tp-size');
|
||||
like($unit, qr/--context-length 32768/, 'unit: context length');
|
||||
like($unit, qr/--mem-fraction-static 0\.9/, 'unit: static memory fraction');
|
||||
is($unit =~ /SGLANG_USE_AITER/ ? 'yes' : 'no', 'no',
|
||||
'unit: no Radeon variables on a non-Radeon host');
|
||||
like($unit, qr/WantedBy=multi-user\.target/, 'unit: install section');
|
||||
like($unit, qr/Restart=on-failure/, 'unit: restart policy');
|
||||
|
||||
my $unit_radeon = systemd_content({
|
||||
model => 'ZhipuAI/GLM-5.3',
|
||||
host => '::1',
|
||||
port => 8000,
|
||||
tensor_parallel => 1,
|
||||
max_model_len => 4096,
|
||||
gpu_memory_utilization => '0.9',
|
||||
state_dir => '/opt/sglang',
|
||||
image => 'local/sglang-rocm:latest',
|
||||
env_file => '/etc/sysconfig/sglang',
|
||||
radeon_env => ['SGLANG_USE_AITER=false', 'SGLANG_ROCM_FUSED_DECODE_MLA=false'],
|
||||
});
|
||||
like($unit_radeon, qr/Environment=SGLANG_USE_AITER=false/, 'unit: AITER off on Radeon');
|
||||
like($unit_radeon, qr/Environment=SGLANG_ROCM_FUSED_DECODE_MLA=false/,
|
||||
'unit: fused decode MLA off on Radeon');
|
||||
|
||||
# ---- parse_os_release reads the host (smoke test) ------------------------
|
||||
my %release = parse_os_release();
|
||||
is(exists $release{ID} ? 'present' : 'absent', 'present', 'os-release: ID is parsed');
|
||||
|
||||
# ---- arguments -----------------------------------------------------------
|
||||
my @ARGV_COPY = @ARGV;
|
||||
local @ARGV = ('--model', 'ZhipuAI/GLM-5.3', '--port=9000', '--tensor-parallel', '2');
|
||||
my %args = parse_args();
|
||||
is($args{model}, 'ZhipuAI/GLM-5.3', 'args: --model value');
|
||||
is($args{port}, '9000', 'args: --port=9000 inline form');
|
||||
is($args{tensor_parallel}, '2', 'args: --tensor-parallel value');
|
||||
is($args{service_name}, 'sglang', 'args: service name default');
|
||||
is($args{state_dir}, '/opt/sglang', 'args: state dir default');
|
||||
is($args{cert_dir}, '/etc/ssl/sglang', 'args: cert dir default');
|
||||
|
||||
@ARGV = ('--dry-run', '--uninstall', '--rocm-flavour', 'rocm720');
|
||||
my %args2 = parse_args();
|
||||
is($args2{dry_run}, 1, 'args: --dry-run');
|
||||
is($args2{uninstall}, 1, 'args: --uninstall');
|
||||
is($args2{rocm_flavour}, 'rocm720', 'args: --rocm-flavour');
|
||||
|
||||
@ARGV = @ARGV_COPY;
|
||||
|
||||
print "\n" . ($failed
|
||||
? "$failed FAILED of " . ($passed + $failed)
|
||||
: "all $passed checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
@@ -0,0 +1,280 @@
|
||||
#!/usr/bin/env perl
|
||||
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||||
# SPDX-License-Identifier: MIT
|
||||
|
||||
# Checks for system-diag.pl: the JSON encoder, the calendar and formatting helpers,
|
||||
# the address validation and the section result reader.
|
||||
#
|
||||
# Run from anywhere: perl tests/system-diag.pl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
|
||||
$root = "./$root" if $root !~ m{^/};
|
||||
require "$root/system-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 like {
|
||||
my ($got, $re, $label) = @_;
|
||||
my $matched = (defined $got && $got =~ $re) ? 1 : 0;
|
||||
if ($matched) {
|
||||
$passed++;
|
||||
print "ok $label\n";
|
||||
return 1;
|
||||
}
|
||||
$failed++;
|
||||
print "FAIL $label\n got: " . (defined $got ? $got : 'undef') . "\n want: $re\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# JSON
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(json_quote('plain'), '"plain"', 'json_quote: a plain word');
|
||||
is(json_quote("a\"b"), '"a\\"b"', 'json_quote: a double quote is escaped');
|
||||
is(json_quote("a\nb"), '"a\\nb"', 'json_quote: a newline is escaped');
|
||||
is(json_quote("a\tb"), '"a\\tb"', 'json_quote: a tab is escaped');
|
||||
is(json_quote('back\\slash'), '"back\\\\slash"', 'json_quote: a backslash is escaped');
|
||||
|
||||
my $encoded = json_encode({ a => 1, b => 'x', c => [1, 2], d => undef, e => 1.5 });
|
||||
like($encoded, qr/"a": 1/, 'json_encode: an integer');
|
||||
like($encoded, qr/"b": "x"/, 'json_encode: a string');
|
||||
like($encoded, qr/"d": null/, 'json_encode: an undefined value');
|
||||
like($encoded, qr/"e": 1\.5/, 'json_encode: a float');
|
||||
like($encoded, qr/"c": \[\s*1,\s*2\s*\]/s, 'json_encode: an array');
|
||||
like($encoded, qr/\A\{\n/, 'json_encode: an object opens on its own line');
|
||||
like($encoded, qr/\}\n\z/, 'json_encode: the document ends with a newline');
|
||||
|
||||
like(json_encode([1, 2, 3]), qr/\A\[\n/, 'json_encode: a top-level array');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Calendar and time
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(_days_from_civil(1970, 1, 1), 0, 'calendar: the epoch is day zero');
|
||||
is(_days_from_civil(1970, 1, 2), 1, 'calendar: the next day');
|
||||
is(_days_from_civil(1969, 12, 31), -1, 'calendar: the day before the epoch');
|
||||
is(_days_from_civil(2000, 3, 1), 11017, 'calendar: the day after the leap day of 2000');
|
||||
# Cross-checked with the system's own calendar: timegm for that date over 86400.
|
||||
is(_days_from_civil(2026, 9, 17), 20713, 'calendar: a current date');
|
||||
|
||||
local $ENV{TZ} = 'UTC';
|
||||
is(timestamp_fields(0), '1970-01-01T00:00:00+0000', 'timestamp: the epoch in UTC');
|
||||
is(timestamp_fields(86400), '1970-01-02T00:00:00+0000', 'timestamp: one day on');
|
||||
like(timestamp_fields(1787961600), qr/\A\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}[+-]\d{4}\z/,
|
||||
'timestamp: the shape of a timestamp');
|
||||
like(utc_offset(time()), qr/\A[+-]\d{4}\z/, 'timestamp: the offset has a sign and four digits');
|
||||
|
||||
like(uptime_human(90061), qr/1/, 'uptime: a day is reported');
|
||||
like(uptime_human(0), qr/\d/, 'uptime: zero still reads as a duration');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Bars and percentages
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# The bar carries colour codes around its cells and the percentage after them, so the
|
||||
# assertions strip the codes first.
|
||||
sub bar_plain {
|
||||
my ($text) = @_;
|
||||
$text =~ s/\e\[[0-9;]*m//g;
|
||||
return $text;
|
||||
}
|
||||
|
||||
is(bar_plain(_bar(50, 100, 10)), "\xe2\x96\x88" x 5 . "\xe2\x96\x91" x 5 . ' 50%',
|
||||
'bar: half of ten cells');
|
||||
is(bar_plain(_bar(100, 100, 10)), "\xe2\x96\x88" x 10 . ' 100%', 'bar: a full bar');
|
||||
is(bar_plain(_bar(0, 100, 10)), "\xe2\x96\x91" x 10 . ' 0%', 'bar: an empty bar');
|
||||
is(bar_plain(_bar(0, 0, 10)), "\xe2\x96\x91" x 10 . ' 0%', 'bar: a zero maximum does not divide');
|
||||
# Colour is off when stdout is not a terminal, which is how the tests run, so the bar
|
||||
# is asserted plain here.
|
||||
|
||||
# Deltas: 1000 jiffies in total, 800 of them idle and iowait, so 200 are busy.
|
||||
is(usage_percent([100, 0, 100, 800, 100], [200, 0, 200, 1600, 100]), '20.0',
|
||||
'usage: a fifth of the delta is busy');
|
||||
is(usage_percent([0, 0, 0, 100, 0], [0, 0, 0, 200, 0]), '0.0', 'usage: an idle machine');
|
||||
is(usage_percent([0, 0, 0], [1, 1, 1]), '0.0', 'usage: a short sample is zero');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Addresses and file systems
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(_valid_ipv6('::1'), 1, 'ipv6: loopback');
|
||||
is(_valid_ipv6('2001:db8::1'), 1, 'ipv6: a documentation prefix');
|
||||
is(_valid_ipv6('127.0.0.1'), 0, 'ipv6: an IPv4 address is not IPv6');
|
||||
is(_valid_ipv6('2001:db8::1::2'), 0, 'ipv6: two shorthands are invalid');
|
||||
is(_valid_ipv6('fe80::1%eth0'), 1, 'ipv6: a scope suffix is accepted');
|
||||
|
||||
is(is_address('192.168.1.1'), 1, 'address: IPv4');
|
||||
is(is_address('::1'), 1, 'address: IPv6');
|
||||
is(is_address('not-an-address'), 0, 'address: a word is not an address');
|
||||
is(is_address(''), 0, 'address: an empty string is not an address');
|
||||
|
||||
is(skip_filesystem('tmpfs', '/run'), 1, 'filesystem: tmpfs is skipped');
|
||||
is(skip_filesystem('overlay', '/'), 1, 'filesystem: overlay is skipped');
|
||||
is(skip_filesystem('ext4', '/dev/sda1'), 0, 'filesystem: ext4 is measured');
|
||||
is(skip_filesystem('xfs', '/dev/mapper/root'), 0, 'filesystem: xfs is measured');
|
||||
|
||||
is(unescape_mount_point('/mnt/\\040data'), '/mnt/ data', 'mounts: an escaped space decodes');
|
||||
is(unescape_mount_point('/mnt/\\011tab'), "/mnt/\ttab", 'mounts: an escaped tab decodes');
|
||||
is(unescape_mount_point('/mnt/\\134back'), '/mnt/\\back', 'mounts: an escaped backslash decodes');
|
||||
is(unescape_mount_point('/plain/path'), '/plain/path', 'mounts: a plain path is untouched');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Results read back from a section worker
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(perl_literal('42'), '42', 'literal: a whole number stays a number');
|
||||
is(perl_literal('08'), "'08'", 'literal: a leading zero is quoted, not octalised');
|
||||
is(perl_literal('010'), "'010'", 'literal: a leading zero with digits is quoted too');
|
||||
|
||||
my $tmp = "/tmp/system-diag-test.$$";
|
||||
open(my $fh, '>', $tmp) or die "cannot write $tmp: $!\n";
|
||||
print {$fh} perl_literal({ cpu => { usage_pct => 12.5 }, host => 'node1', key => '18.0', zeroed => '08' });
|
||||
close($fh);
|
||||
|
||||
my ($value, $error) = read_literal($tmp);
|
||||
is($error, '', 'literal: a written result reads back without error');
|
||||
is($value->{host}, 'node1', 'literal: a string survives the round trip');
|
||||
is($value->{cpu}{usage_pct}, 12.5, 'literal: a float survives the round trip');
|
||||
is($value->{key}, '18.0', 'literal: a numeric-looking string stays a string');
|
||||
is($value->{zeroed}, '08', 'literal: a leading-zero string survives the round trip');
|
||||
unlink($tmp);
|
||||
|
||||
my ($missing, $missing_error) = read_literal("$tmp.does-not-exist");
|
||||
is($missing, undef, 'literal: a missing result file yields nothing');
|
||||
like($missing_error, qr/was not written/, 'literal: a missing result file says so');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# External tools, through fixture binaries on a private PATH
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# A collector is exercised end to end by replacing its external tool with a Perl
|
||||
# fixture that prints a known answer, so the parsing is checked against the shape
|
||||
# of the real tool's output without needing the tool installed.
|
||||
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/system-diag-test-bin.$$";
|
||||
mkdir($bindir, 0700) or die "cannot create $bindir: $!\n";
|
||||
|
||||
# The fixture PATH is scoped, so the rest of the checks see the real one.
|
||||
{
|
||||
local $ENV{PATH} = "$bindir:$ENV{PATH}";
|
||||
|
||||
install_fake_bin($bindir, 'lspci', <<'FIXTURE');
|
||||
exit 0 if @ARGV && $ARGV[0] eq '-d';
|
||||
print "0000:01:00.0 VGA compatible controller: Intel Corporation UHD Graphics 730 (rev 01)\n";
|
||||
print "0000:02:00.0 3D controller: Huawei Technologies Co., Ltd. Ascend 910A\n";
|
||||
FIXTURE
|
||||
my $gpu = lspci_gpu();
|
||||
is($gpu->{cards}[0]{model}, 'Intel Corporation UHD Graphics 730 (rev 01)',
|
||||
'lspci: the model is the description, not the whole line');
|
||||
is($gpu->{cards}[0]{vendor}, 'Intel', 'lspci: Corporation does not read as AMD');
|
||||
is($gpu->{cards}[1]{vendor}, 'Huawei', 'lspci: an Ascend card has its vendor');
|
||||
|
||||
install_fake_bin($bindir, 'systemctl', <<'FIXTURE');
|
||||
if (@ARGV && $ARGV[0] eq '--failed') {
|
||||
print "nginx.service loaded failed failed A high performance web server\n";
|
||||
}
|
||||
FIXTURE
|
||||
my $failed = failed_units();
|
||||
is($failed->[0]{unit}, 'nginx.service', 'services: a failed unit is listed');
|
||||
is($failed->[0]{state}, 'failed', 'services: the state is the unit state, not the load state');
|
||||
|
||||
install_fake_bin($bindir, 'iostat', <<'FIXTURE');
|
||||
print "Device r/s rkB/s w/s wkB/s\n";
|
||||
print "sda 4.00 2048.00 10.00 512.00\n\n";
|
||||
print "Device r/s rkB/s w/s wkB/s\n";
|
||||
print "sda 8.00 4096.00 20.00 1024.00\n";
|
||||
FIXTURE
|
||||
my $io = disk_io_stats();
|
||||
is($io->{devices}[0]{tps}, '28.00', 'iostat: the second report is the one measured');
|
||||
is($io->{devices}[0]{read_mb_s}, '4.00', 'iostat: a kB/s column converts to MB/s');
|
||||
is($io->{devices}[0]{write_mb_s}, '1.00', 'iostat: kB/s writes convert to MB/s');
|
||||
|
||||
# Older sysstat printed MB/s columns; dividing those again would report a value
|
||||
# 1024 times too small.
|
||||
install_fake_bin($bindir, 'iostat', <<'FIXTURE');
|
||||
print "Device: rrqm/s wrqm/s r/s w/s rMB/s wMB/s\n";
|
||||
print "sda 0.00 0.00 4.00 10.00 16.00 8.00\n";
|
||||
FIXTURE
|
||||
$io = disk_io_stats();
|
||||
is($io->{devices}[0]{read_mb_s}, '16.00', 'iostat: an MB/s column is not divided again');
|
||||
is($io->{devices}[0]{write_mb_s}, '8.00', 'iostat: MB/s writes stay in MB/s');
|
||||
|
||||
# A machine with lspci and no GPU at all: collect_gpu answers undef, which is a
|
||||
# result and must not reach the report as a collection failure.
|
||||
install_fake_bin($bindir, 'lspci', <<'FIXTURE');
|
||||
exit 0 if @ARGV && $ARGV[0] eq '-d';
|
||||
print "00:1f.2 SATA controller: Intel Corporation 82801IR SATA [AHCI mode]\n";
|
||||
FIXTURE
|
||||
my $collected = collect_all(['gpu'], 0);
|
||||
check(!(ref($collected->{gpu}) eq 'HASH' && $collected->{gpu}{error}),
|
||||
'collect: no GPU is a result, not a collection failure');
|
||||
}
|
||||
|
||||
unlink(grep { -f } glob("$bindir/*"));
|
||||
rmdir($bindir);
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Health
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $health = compute_health({});
|
||||
is(ref($health), 'HASH', 'health: the verdict is a hash');
|
||||
is($health->{score}, undef, 'health: no data has no score');
|
||||
is($health->{grade}, 'N/A', 'health: no data is not graded');
|
||||
is($health->{max_score}, 100, 'health: the maximum is one hundred');
|
||||
# An ungraded run is the only verdict this test can construct, so the letter is not
|
||||
# asserted here: it depends on a populated collection, which the script's own run
|
||||
# exercises. A check whose condition is a match must be forced into a boolean, since
|
||||
# in an argument list a failed match yields the empty list and shifts the label into
|
||||
# the condition slot.
|
||||
check(ref($health->{breakdown}) eq 'HASH', 'health: the breakdown is a hash');
|
||||
check(ref($health->{factors_skipped}) eq 'ARRAY', 'health: the skipped factors are listed');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Arguments
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my @saved = @ARGV;
|
||||
@ARGV = ('--json', '--section', 'cpu,memory');
|
||||
my %args = parse_args();
|
||||
is($args{json}, 1, 'args: --json');
|
||||
is($args{section}, 'cpu,memory', 'args: --section takes a list');
|
||||
@ARGV = ();
|
||||
my %defaults = parse_args();
|
||||
is($defaults{json}, 0, 'args: json is off by default');
|
||||
is($defaults{section}, '', 'args: every section by default');
|
||||
@ARGV = @saved;
|
||||
|
||||
print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
@@ -0,0 +1,325 @@
|
||||
#!/usr/bin/env perl
|
||||
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||||
# SPDX-License-Identifier: MIT
|
||||
|
||||
# Checks for system-optimise.pl: the version comparison against rpm's own
|
||||
# implementation, the pure helpers and the JSON decoder.
|
||||
#
|
||||
# Run from anywhere: perl tests/system-optimise.pl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
|
||||
$root = "./$root" if $root !~ m{^/};
|
||||
require "$root/system-optimise.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 like {
|
||||
my ($got, $re, $label) = @_;
|
||||
my $matched = (defined $got && $got =~ $re) ? 1 : 0;
|
||||
if ($matched) {
|
||||
$passed++;
|
||||
print "ok $label\n";
|
||||
return 1;
|
||||
}
|
||||
$failed++;
|
||||
print "FAIL $label\n got: " . (defined $got ? $got : 'undef') . "\n want: $re\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Version comparison, against rpm itself
|
||||
# ---------------------------------------------------------------------------
|
||||
#
|
||||
# rpm carries the definition of its own ordering, so the comparison is checked
|
||||
# against rpm's implementation rather than against an expectation written here
|
||||
# by hand. The corpus is fixed: the same pairs every run. No pair may carry
|
||||
# a dash or a colon: the oracle below parses its arguments as
|
||||
# [epoch:]version[-release] and would split on them, so those shapes belong to
|
||||
# the EVR corpus further down.
|
||||
|
||||
my @VERSION_PAIRS = (
|
||||
['1.0', '1.1'],
|
||||
['1.1', '1.0'],
|
||||
['1.0', '1.0'],
|
||||
['1.09', '1.9'],
|
||||
['1.0', '1.0.0'],
|
||||
['1.0a', '1.0'],
|
||||
['1.0a', '1.0b'],
|
||||
['1.0', '1.0~rc1'],
|
||||
['1.0~rc1', '1.0~rc2'],
|
||||
['1.0~rc1', '1.0~rc1'],
|
||||
['1.0^post1', '1.0'],
|
||||
['1.0^post1', '1.0^post2'],
|
||||
['2.0', '10.0'],
|
||||
['1.2.3', '1.2.3'],
|
||||
['1.2.3.4', '1.2.3'],
|
||||
['5.14.0', '5.14.0.1'],
|
||||
['0.9', '1.0'],
|
||||
['1.0', '1.0b'],
|
||||
['2024.1', '2024.10'],
|
||||
['1.0.rc1', '1.0'],
|
||||
['1.0^post1', '1.0b'],
|
||||
['1.0', '1.0^'],
|
||||
['1.0.~rc1', '1.0~rc1'],
|
||||
['1.0^x', '1.0~x'],
|
||||
['1.0.1', '1.0^post1'],
|
||||
);
|
||||
|
||||
sub rpm_vercmp_oracle {
|
||||
my ($pairs) = @_;
|
||||
# rpm's macro parser counts braces, so the lua body below carries none: the corpus
|
||||
# travels as one flat string, and the pattern splits it back into pairs.
|
||||
my $spec = join(';', map { "$_->[0],$_->[1]" } @$pairs) . ';';
|
||||
# a comma or a semicolon would silently shift the pairing, so both travel
|
||||
# with the characters that break the lua literal
|
||||
return undef if grep { m{["\\{};,]} } map { @$_ } @$pairs;
|
||||
my $lua = '%{lua: local s="' . $spec . '";'
|
||||
. q{ for l,r in s:gmatch("([^,]+),([^;]+);") do io.write(rpm.vercmp(l,r), "\n") end};
|
||||
$lua .= '}';
|
||||
my $fh;
|
||||
open($fh, '-|', 'rpm', '--eval', $lua) or return undef;
|
||||
my @out = <$fh>;
|
||||
close($fh);
|
||||
return undef unless $? == 0;
|
||||
chomp @out;
|
||||
return \@out;
|
||||
}
|
||||
|
||||
my $oracle = rpm_vercmp_oracle(\@VERSION_PAIRS);
|
||||
if (!defined $oracle) {
|
||||
print "skip version comparison: rpm is not installed (the oracle)\n";
|
||||
}
|
||||
else {
|
||||
my $i = 0;
|
||||
for my $pair (@VERSION_PAIRS) {
|
||||
$i++;
|
||||
my ($left, $right) = @$pair;
|
||||
my $mine = rpmvercmp($left, $right);
|
||||
my $sign = $mine <=> 0;
|
||||
is($sign, $oracle->[$i - 1], "rpmvercmp($left, $right) matches rpm");
|
||||
}
|
||||
}
|
||||
|
||||
is(rpmvercmp('1.0', '1.0'), 0, 'rpmvercmp: equal versions');
|
||||
check(rpmvercmp('1.0~rc1', '1.0') < 0, 'rpmvercmp: a tilde sorts before the release');
|
||||
check(rpmvercmp('1.0^post1', '1.0') > 0, 'rpmvercmp: a caret sorts after the release');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# EVR comparison
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(rpm_evr_cmp('1:1.0-1', '1:1.0-2'), -1, 'evr: release decides');
|
||||
is(rpm_evr_cmp('1:1.0-1', '2:1.0-1'), -1, 'evr: epoch decides');
|
||||
is(rpm_evr_cmp('1:1.0-1', '1:1.0-1'), 0, 'evr: identical');
|
||||
check(rpm_evr_cmp('2:1.0-1', '1:9.9-9') > 0, 'evr: an epoch outranks any version');
|
||||
is(rpm_evr_cmp('1.0-1', '1:1.0-1'), -1, 'evr: a missing epoch is zero');
|
||||
|
||||
# The same oracle drives the EVR comparison, now with dashes and colons:
|
||||
# rpm.vercmp parses its arguments as [epoch:]version[-release] and compares
|
||||
# field by field, which is exactly the contract of rpm_evr_cmp. The pairs
|
||||
# below are the shapes the kernel query produces, plus the cases where
|
||||
# comparing version and release as one string would order differently.
|
||||
my @EVR_PAIRS = (
|
||||
['1.0-2', '1.0.1-1'],
|
||||
['1.0', '1.0-1'],
|
||||
['1.0-1-2', '1.0-1'],
|
||||
['2:1.0-1', '1.0-1'],
|
||||
['0:1.0', '1.0'],
|
||||
['1.0~rc1-1', '1.0-1'],
|
||||
['0:6.9.5-100.fc40.x86_64', '0:6.9.6-50.fc40.x86_64'],
|
||||
['0:6.9.5-100.fc40.x86_64', '0:6.9.5-200.fc40.x86_64'],
|
||||
);
|
||||
my $evr_oracle = rpm_vercmp_oracle(\@EVR_PAIRS);
|
||||
if (!defined $evr_oracle) {
|
||||
print "skip EVR comparison: rpm is not installed (the oracle)\n";
|
||||
}
|
||||
else {
|
||||
my $j = 0;
|
||||
for my $pair (@EVR_PAIRS) {
|
||||
$j++;
|
||||
my ($left, $right) = @$pair;
|
||||
my $mine = rpm_evr_cmp($left, $right);
|
||||
my $sign = $mine <=> 0;
|
||||
is($sign, $evr_oracle->[$j - 1], "rpm_evr_cmp($left, $right) matches rpm");
|
||||
}
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Formatting and small helpers
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(format_size(0), '0 B', 'format_size: zero');
|
||||
is(format_size(512), '512 B', 'format_size: under a kilobyte');
|
||||
is(format_size(1024), '1.0 KB', 'format_size: one kilobyte');
|
||||
is(format_size(1536), '1.5 KB', 'format_size: fraction of a kilobyte');
|
||||
is(format_size(1048576), '1.0 MB', 'format_size: one megabyte');
|
||||
is(format_size(1073741824), '1.00 GB', 'format_size: one gigabyte');
|
||||
is(format_size(-1), '0 B', 'format_size: negative is clamped');
|
||||
|
||||
is(kernel_pkg_name('fedora'), 'kernel-core', 'kernel_pkg_name: Fedora');
|
||||
is(kernel_pkg_name('openeuler'), 'kernel', 'kernel_pkg_name: openEuler');
|
||||
is(kernel_pkg_name('centos'), 'kernel-core', 'kernel_pkg_name: CentOS Stream');
|
||||
|
||||
is(last_lines("a\nb\nc\nd\n", 2), 'c | d', 'last_lines: the last two lines, joined');
|
||||
is(last_lines("1\n2\n3\n4\n", 10), '1 | 2 | 3 | 4', 'last_lines: a count above the line number');
|
||||
is(last_lines("\n\n", 3), 'no error output', 'last_lines: blank input is named as no output');
|
||||
|
||||
my ($gone, $left) = split_by_presence(['a', 'b', 'c'], ['b', 'd']);
|
||||
is(join(',', @$gone), 'a,c', 'split_by_presence: gone holds what vanished');
|
||||
is(join(',', @$left), 'b', 'split_by_presence: left holds the survivors');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# JSON decoder
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $decoded = json_decode('{"a":1,"b":[true,false,null],"c":"x\\ny","d":{"e":2.5}}');
|
||||
is(ref($decoded), 'HASH', 'json: an object decodes to a hash');
|
||||
is($decoded->{a}, 1, 'json: an integer');
|
||||
is(ref($decoded->{b}), 'ARRAY', 'json: an array decodes to an array');
|
||||
is($decoded->{b}[0], 1, 'json: true is truthy');
|
||||
is($decoded->{b}[1], 0, 'json: false is falsey');
|
||||
is($decoded->{b}[2], undef, 'json: null is undef');
|
||||
is($decoded->{c}, "x\ny", 'json: an escaped newline');
|
||||
is($decoded->{d}{e}, 2.5, 'json: a nested float');
|
||||
|
||||
my $escaped = json_decode('{"s":"a\"b\\\\c\/d\te"}');
|
||||
is($escaped->{s}, "a\"b\\c/d\te", 'json: quotes, backslashes, a solidus and a tab');
|
||||
|
||||
my $unicode = json_decode('{"s":"\u0041\u00e9"}');
|
||||
is($unicode->{s}, "A\xc3\xa9", 'json: a unicode escape becomes UTF-8 bytes');
|
||||
|
||||
my $empty = json_decode('[]');
|
||||
is(ref($empty), 'ARRAY', 'json: an empty array');
|
||||
is(scalar(@$empty), 0, 'json: an empty array has no elements');
|
||||
|
||||
# The decoder dies on malformed input rather than returning a sentinel, so a caller
|
||||
# that cannot trust its input wraps the call; the test asserts that contract.
|
||||
my $died = eval { json_decode('not json'); 1 } ? 0 : 1;
|
||||
is($died, 1, 'json: malformed input dies rather than returning a value');
|
||||
like($@, qr/unrecognised token/, 'json: the death names the reason');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Arguments
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# parse_args reads the program's arguments, so a test sets them the way a caller does.
|
||||
my @saved = @ARGV;
|
||||
@ARGV = ('--dry-run', '--skip-journal');
|
||||
my %args = parse_args();
|
||||
is($args{dry_run}, 1, 'args: --dry-run sets the flag');
|
||||
is($args{skip_journal}, 1, 'args: --skip-journal sets the flag');
|
||||
is($args{skip_tmp}, 0, 'args: an unset skip stays off');
|
||||
@ARGV = ();
|
||||
my %defaults = parse_args();
|
||||
is($defaults{dry_run}, 0, 'args: dry run defaults to off');
|
||||
@ARGV = @saved;
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Temp cleanup, end to end
|
||||
# ---------------------------------------------------------------------------
|
||||
#
|
||||
# clean_temp_dir drives the real find(1), so the age filter, the deletion and
|
||||
# the verification of what went away are exercised together here, against a
|
||||
# directory this test owns.
|
||||
|
||||
if (!defined find_exe('find')) {
|
||||
print "skip temp cleanup: find is not installed\n";
|
||||
}
|
||||
else {
|
||||
my $dir = "/tmp/system-optimise-test.$$";
|
||||
mkdir($dir, 0700) or die "cannot create $dir: $!\n";
|
||||
my $aged = "$dir/aged.txt";
|
||||
my $fresh = "$dir/fresh.txt";
|
||||
for my $file ($aged, $fresh) {
|
||||
open(my $fh, '>', $file) or die "cannot create $file: $!\n";
|
||||
print {$fh} "test\n";
|
||||
close($fh);
|
||||
}
|
||||
my $old_time = time() - 30 * 86400;
|
||||
utime($old_time, $old_time, $aged);
|
||||
|
||||
my @warnings;
|
||||
my @errors;
|
||||
my ($count, $bytes) = clean_temp_dir($dir, 10,
|
||||
dry_run => 1, warnings => \@warnings, errors => \@errors);
|
||||
is($count, 1, 'temp: dry run counts the one aged file');
|
||||
check(-e $aged, 'temp: dry run leaves the aged file in place');
|
||||
is(scalar(@errors), 0, 'temp: dry run reports no errors');
|
||||
|
||||
($count, $bytes) = clean_temp_dir($dir, 10,
|
||||
dry_run => 0, warnings => \@warnings, errors => \@errors);
|
||||
is($count, 1, 'temp: the real run reports the aged file as removed');
|
||||
check(!-e $aged, 'temp: the aged file is gone');
|
||||
check(-e $fresh, 'temp: the fresh file survives');
|
||||
check($bytes > 0, 'temp: the freed size is above zero');
|
||||
is(scalar(@errors), 0, 'temp: the real run reports no errors');
|
||||
|
||||
my ($again) = clean_temp_dir($dir, 10,
|
||||
dry_run => 0, warnings => \@warnings, errors => \@errors);
|
||||
is($again, 0, 'temp: a second run finds nothing to remove');
|
||||
|
||||
unlink($fresh);
|
||||
rmdir($dir);
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# The command runner and the scratch directory
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# A file that cannot be exec'd: the runner must report 126 and name the
|
||||
# binary, rather than swallowing the reason the exec failed.
|
||||
my $bad_exe = "/tmp/system-optimise-test-noexec.$$";
|
||||
if (open(my $fh, '>', $bad_exe)) {
|
||||
print {$fh} "#!/nonexistent/interpreter\n";
|
||||
close($fh);
|
||||
chmod(0755, $bad_exe);
|
||||
my $result = run([$bad_exe]);
|
||||
is($result->{rc}, 126, 'run: a failed exec reports 126');
|
||||
like($result->{err}, qr/cannot execute/, 'run: the failure names the binary');
|
||||
unlink($bad_exe);
|
||||
}
|
||||
else {
|
||||
print "skip runner: cannot write $bad_exe\n";
|
||||
}
|
||||
|
||||
# An empty TMPDIR must fall back to /tmp rather than placing the scratch
|
||||
# directory at the filesystem root.
|
||||
my $empty_tmpdir = eval {
|
||||
remove_scratch(); # the cached directory would bypass the fallback
|
||||
local $ENV{TMPDIR} = '';
|
||||
my $scratch = scratch_dir();
|
||||
remove_scratch();
|
||||
return $scratch;
|
||||
};
|
||||
if (defined $empty_tmpdir) {
|
||||
like($empty_tmpdir, qr{^/tmp/system-optimise\.},
|
||||
'scratch_dir: an empty TMPDIR falls back to /tmp');
|
||||
}
|
||||
else {
|
||||
print "skip scratch_dir: cannot create a scratch directory\n";
|
||||
}
|
||||
|
||||
print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
@@ -0,0 +1,243 @@
|
||||
#!/usr/bin/env perl
|
||||
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||||
# SPDX-License-Identifier: MIT
|
||||
|
||||
# Checks for workstation-setup.pl: the JSON decoder, the architecture mapping, the
|
||||
# checksum file reader, the atomic writer, the runner and user command helpers,
|
||||
# the Brave repo pin, the IDE launcher links and the supported system set.
|
||||
#
|
||||
# Run from anywhere: perl tests/workstation-setup.pl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
|
||||
$root = "./$root" if $root !~ m{^/};
|
||||
require "$root/workstation-setup.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);
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# JSON
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $decoded = json_decode('{"a":1,"b":[true,false,null],"c":"x\\ny","d":{"e":2.5}}');
|
||||
is(ref($decoded), 'HASH', 'json: an object decodes to a hash');
|
||||
is($decoded->{a}, 1, 'json: an integer');
|
||||
is($decoded->{b}[0], 1, 'json: true is truthy');
|
||||
is($decoded->{b}[1], 0, 'json: false is falsey');
|
||||
is($decoded->{b}[2], undef, 'json: null is undef');
|
||||
is($decoded->{c}, "x\ny", 'json: an escaped newline');
|
||||
is($decoded->{d}{e}, 2.5, 'json: a nested float');
|
||||
|
||||
my $strings = json_decode('{"s":"a\"b\\\\c\/d\te","u":"\u0041\u00e9"}');
|
||||
is($strings->{s}, "a\"b\\c/d\te", 'json: quotes, backslashes, a solidus and a tab');
|
||||
is($strings->{u}, "A\xc3\xa9", 'json: a unicode escape becomes UTF-8 bytes');
|
||||
|
||||
my $numbers = json_decode('{"i":-12,"f":1e3,"z":0,"n":-0.5}');
|
||||
is($numbers->{i}, -12, 'json: a negative integer');
|
||||
is($numbers->{f}, 1000, 'json: an exponent');
|
||||
is($numbers->{z}, 0, 'json: zero');
|
||||
is($numbers->{n}, -0.5, 'json: a negative float');
|
||||
|
||||
my $empty = json_decode('[]');
|
||||
is(ref($empty), 'ARRAY', 'json: an empty array');
|
||||
is(scalar(@$empty), 0, 'json: an empty array has no elements');
|
||||
|
||||
my $whitespace = json_decode(" {\n \"a\" : 1\n} ");
|
||||
is($whitespace->{a}, 1, 'json: whitespace around and inside is skipped');
|
||||
|
||||
# Malformed input dies with the offset, so a caller that cannot trust its input wraps
|
||||
# the call; the test asserts that contract rather than a sentinel value.
|
||||
for my $bad ('', '{', '[1,]', 'nope', '{"a":}') {
|
||||
my $died = eval { json_decode($bad); 1 } ? 0 : 1;
|
||||
is($died, 1, "json: malformed input dies (" . ($bad eq '' ? 'empty' : $bad) . ")");
|
||||
}
|
||||
my $reason = eval { json_decode('nope'); '' } || $@;
|
||||
check($reason =~ /offset 0/, 'json: the death names the offset');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Architecture
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $arch = go_arch();
|
||||
check(!defined $arch || $arch =~ /^(amd64|arm64)$/,
|
||||
'arch: the machine maps to a Go architecture or to nothing');
|
||||
|
||||
my $tmp = "/tmp/workstation-test.$$";
|
||||
|
||||
my $sums = "$tmp.sums";
|
||||
open(my $fh, '>', $sums) or die "cannot write $sums: $!\n";
|
||||
print {$fh} 'a' x 64 . " ./tool.tar.gz\n";
|
||||
print {$fh} 'b' x 64 . " other.tar.gz\n";
|
||||
close($fh);
|
||||
is(sha256_from_sums($sums, 'other.tar.gz'), 'b' x 64, 'sums: a name is found in the file');
|
||||
is(sha256_from_sums($sums, 'missing.tar.gz'), undef, 'sums: a name that is absent yields nothing');
|
||||
is(sha256_from_sums($sums, './tool.tar.gz'), 'a' x 64, 'sums: the name as listed is matched');
|
||||
is(sha256_from_sums($sums, 'tool.tar.gz'), undef, 'sums: a name that is listed differently is not matched');
|
||||
unlink($sums);
|
||||
is(sha256_from_sums("$tmp.nothing", 'x'), undef, 'sums: a missing file yields nothing');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Atomic writes
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# atomic_write settles the owner, which for a new file is root, so it needs root to
|
||||
# run; as an ordinary user the write is refused and the check is skipped rather than
|
||||
# pretended. The container runs exercise the real path.
|
||||
my $target = "$tmp.target";
|
||||
# The contract is a death on failure and no value on success, which is how every
|
||||
# caller uses it: eval { atomic_write(...); 1 }.
|
||||
if ($> == 0) {
|
||||
my $written = eval { atomic_write($target, "one\n"); 1 } ? 1 : 0;
|
||||
is($written, 1, 'atomic_write: a new file is written');
|
||||
is(slurp($target), "one\n", 'atomic_write: the content is there');
|
||||
$written = eval { atomic_write($target, "two\n"); 1 } ? 1 : 0;
|
||||
is($written, 1, 'atomic_write: an existing file is replaced');
|
||||
is(slurp($target), "two\n", 'atomic_write: the new content is there');
|
||||
check(!-e "$target.$$" . '.tmp', 'atomic_write: no temporary file is left behind');
|
||||
unlink($target);
|
||||
}
|
||||
else {
|
||||
my $died = eval { atomic_write($target, "one\n"); 1 } ? 0 : 1;
|
||||
is($died, 1, 'atomic_write: dies when it cannot own the target, as an ordinary user');
|
||||
check(!-e "$target.$$" . '.tmp', 'atomic_write: the temporary file is cleaned up');
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Arguments
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my @saved = @ARGV;
|
||||
@ARGV = ('--dry-run', '--skip-rpm', '--skip-go');
|
||||
my %args = parse_args();
|
||||
is($args{dry_run}, 1, 'args: --dry-run');
|
||||
is($args{skip_rpm}, 1, 'args: --skip-rpm');
|
||||
is($args{skip_go}, 1, 'args: --skip-go');
|
||||
is($args{skip_update}, 0, 'args: an unset skip stays off');
|
||||
@ARGV = ();
|
||||
my %defaults = parse_args();
|
||||
is($defaults{dry_run}, 0, 'args: dry run is off by default');
|
||||
@ARGV = @saved;
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Command composition for the real user
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
{
|
||||
local $ENV{SUDO_USER};
|
||||
delete $ENV{SUDO_USER};
|
||||
is(join(' ', @{ user_command(['flatpak', 'info', '--user', 'org.example.App']) }),
|
||||
'flatpak info --user org.example.App',
|
||||
'user_command: without SUDO_USER the command itself is the whole list');
|
||||
my $direct = run_as_user(['/bin/echo', 'as-user']);
|
||||
is($direct->{out}, "as-user\n",
|
||||
'run_as_user: without SUDO_USER the command runs directly');
|
||||
$ENV{SUDO_USER} = 'someuser';
|
||||
is(join(' ', @{ user_command(['flatpak', 'uninstall', '-y', 'org.example.App']) }),
|
||||
'sudo -u someuser flatpak uninstall -y org.example.App',
|
||||
'user_command: SUDO_USER becomes a sudo -u prefix before the command');
|
||||
is(join(' ', @{ user_command(['rustup-init', '-y'],
|
||||
{ RUSTUP_HOME => '/h', CARGO_HOME => '/c' }) }),
|
||||
'sudo -u someuser env CARGO_HOME=/c RUSTUP_HOME=/h rustup-init -y',
|
||||
'user_command: env assignments come sorted between env(1) and the command');
|
||||
}
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Runner exit codes
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
is(run(['perl', '-e', 'exit 7'])->{rc}, 7, 'run: an exit code passes through');
|
||||
is(run(['perl', '-e', q{kill 9, $$}])->{rc}, 137,
|
||||
'run: a child killed by a signal reports 128+signal, not success');
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Repo gpgkey pinning
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $repo_file = "$tmp.repo";
|
||||
my $key_file = "$tmp.key";
|
||||
open(my $key_out, '>', $key_file) or die "cannot write $key_file: $!\n";
|
||||
print {$key_out} "verified key material\n";
|
||||
close($key_out);
|
||||
open(my $repo_out, '>', $repo_file) or die "cannot write $repo_file: $!\n";
|
||||
print {$repo_out} "[brave-browser]\nbaseurl=https://example.com/brave/x86_64/\n"
|
||||
. "\ngpgkey=https://example.com/brave-core.asc\nenabled=1\n";
|
||||
close($repo_out);
|
||||
is(pin_brave_repo_gpgkey($repo_file, $key_file), 1,
|
||||
'pin: a URL gpgkey is pinned to the local key file');
|
||||
my $pinned_content = slurp($repo_file);
|
||||
check(index($pinned_content, "gpgkey=file://$key_file") >= 0,
|
||||
'pin: the gpgkey line points at the key file');
|
||||
check(index($pinned_content, 'baseurl=https://example.com/brave/x86_64/') >= 0,
|
||||
'pin: the untouched lines survive the rewrite');
|
||||
check($pinned_content =~ /\n\n/, 'pin: a blank line survives the rewrite');
|
||||
is(pin_brave_repo_gpgkey($repo_file, $key_file), 1,
|
||||
'pin: an already pinned file is left as it is');
|
||||
unlink($repo_file);
|
||||
is(pin_brave_repo_gpgkey($repo_file, $key_file), 0,
|
||||
'pin: a missing repo file fails without dying');
|
||||
unlink($key_file);
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# JetBrains launcher links
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
my $ide_home = "$tmp.ide";
|
||||
my $ide_bin = "$ide_home/bin";
|
||||
my $ide_desktop = "$ide_home/applications";
|
||||
make_dirs($ide_bin) or die "cannot create $ide_bin\n";
|
||||
for my $dir ("$ide_home/GoLand-2026.1", "$ide_home/GoLand-2026.2") {
|
||||
make_dirs("$dir/bin") or die "cannot create $dir/bin\n";
|
||||
my $launcher = "$dir/bin/goland.sh";
|
||||
open(my $launch_out, '>', $launcher) or die "cannot write $launcher: $!\n";
|
||||
close($launch_out);
|
||||
chmod(0755, $launcher);
|
||||
}
|
||||
is(jetbrains_links('GoLand', "$ide_home/GoLand-2026.1", $ide_bin, $ide_desktop), 1,
|
||||
'ide links: an install with a launcher gets its links');
|
||||
is(readlink("$ide_bin/goland") // '', "$ide_home/GoLand-2026.1/bin/goland.sh",
|
||||
'ide links: the symlink points at the launcher');
|
||||
is(jetbrains_links('GoLand', "$ide_home/GoLand-2026.2", $ide_bin, $ide_desktop), 1,
|
||||
'ide links: a newer install repoints the symlink');
|
||||
is(readlink("$ide_bin/goland") // '', "$ide_home/GoLand-2026.2/bin/goland.sh",
|
||||
'ide links: the symlink follows the newer launcher');
|
||||
is(jetbrains_links('GoLand', "$ide_home/GoLand-0.0.0", $ide_bin, $ide_desktop), 0,
|
||||
'ide links: a missing launcher fails the links');
|
||||
if ($> == 0) {
|
||||
my $entry = slurp("$ide_desktop/jetbrains-goland.desktop");
|
||||
check(index($entry, "Exec=\"$ide_home/GoLand-2026.2/bin/goland.sh\"") >= 0,
|
||||
'ide links: the menu entry names the launcher');
|
||||
}
|
||||
remove_tree($ide_home);
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Supported systems
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# The supported set is a lexical in the script, so its contract is checked
|
||||
# through the usage text the set builds: Fedora advertised, nothing else.
|
||||
check(index(usage(), 'workstation setup for Fedora') >= 0 && index(usage(), 'openEuler') < 0,
|
||||
'usage: only Fedora is advertised');
|
||||
|
||||
print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
|
||||
exit($failed ? 1 : 0);
|
||||
Reference in New Issue
Block a user