feat: initial release of the scripts collection
Assisted-by: GLM 5.3 Flash
This commit is contained in:
@@ -0,0 +1,104 @@
|
|||||||
|
# Deploy: the scripts over rsync. Runs on every push to main and on manual dispatch,
|
||||||
|
# because scripts are not versioned and go live immediately.
|
||||||
|
#
|
||||||
|
# Requires secrets: DEPLOY_HOST, DEPLOY_USER, DEPLOY_PATH, DEPLOY_PASSWORD,
|
||||||
|
# DEPLOY_KNOWN_HOSTS (the host key, from ssh-keyscan -t ed25519 HOST).
|
||||||
|
#
|
||||||
|
# Every step is one command, and the scripted steps are Perl rather than shell, so
|
||||||
|
# nothing has to be trusted to a shell option and no shell ever parses an argument.
|
||||||
|
# The Perl uses builtins only. The host key is pinned from the secret before the
|
||||||
|
# first connection: pointing UserKnownHostsFile at /dev/null would disable
|
||||||
|
# verification and turn every deploy into a blind trust on first use.
|
||||||
|
name: Deploy
|
||||||
|
|
||||||
|
on:
|
||||||
|
push:
|
||||||
|
branches: [main]
|
||||||
|
workflow_dispatch:
|
||||||
|
|
||||||
|
jobs:
|
||||||
|
deploy:
|
||||||
|
runs-on: alpine
|
||||||
|
timeout-minutes: 10
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v7
|
||||||
|
|
||||||
|
- name: Install Perl
|
||||||
|
# The alpine base image carries no Perl.
|
||||||
|
run: apk add --no-cache perl
|
||||||
|
|
||||||
|
- name: Generate SHA256SUMS
|
||||||
|
run: |
|
||||||
|
perl -e '
|
||||||
|
my @files = sort glob q{*.pl};
|
||||||
|
@files or die qq{ERROR: no scripts found\n};
|
||||||
|
open(my $out, q{>}, q{SHA256SUMS}) or die qq{SHA256SUMS: $!\n};
|
||||||
|
for my $file (@files) {
|
||||||
|
open(my $sums, q{-|}, q{sha256sum}, $file) or die qq{sha256sum: $!\n};
|
||||||
|
my $line = <$sums>;
|
||||||
|
# close waits for the child and answers false when it failed.
|
||||||
|
close($sums) or die qq{ERROR: sha256sum failed for $file\n};
|
||||||
|
defined $line or die qq{ERROR: sha256sum produced nothing for $file\n};
|
||||||
|
print $out $line;
|
||||||
|
print $line;
|
||||||
|
}
|
||||||
|
close($out) or die qq{SHA256SUMS: $!\n};
|
||||||
|
'
|
||||||
|
|
||||||
|
- name: Pin the host key
|
||||||
|
env:
|
||||||
|
DEPLOY_KNOWN_HOSTS: ${{ secrets.DEPLOY_KNOWN_HOSTS }}
|
||||||
|
run: |
|
||||||
|
# The runner has no persistent known_hosts, so the key comes from a secret
|
||||||
|
# and is written before the first connection.
|
||||||
|
perl -e '
|
||||||
|
my $key = $ENV{DEPLOY_KNOWN_HOSTS} // q{};
|
||||||
|
$key =~ m{\S} or die qq{ERROR: DEPLOY_KNOWN_HOSTS is empty\n};
|
||||||
|
my $dir = ($ENV{HOME} // q{.}) . q{/.ssh};
|
||||||
|
mkdir($dir, 0700) unless -d $dir;
|
||||||
|
open(my $out, q{>}, qq{$dir/known_hosts}) or die qq{known_hosts: $!};
|
||||||
|
print $out $key;
|
||||||
|
$key =~ m{\n\z} or print $out qq{\n};
|
||||||
|
close($out);
|
||||||
|
chmod(0600, qq{$dir/known_hosts}) or die qq{chmod: $!};
|
||||||
|
print qq{host key pinned in $dir/known_hosts\n};
|
||||||
|
'
|
||||||
|
|
||||||
|
- name: Deploy via rsync
|
||||||
|
env:
|
||||||
|
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||||
|
DEPLOY_USER: ${{ secrets.DEPLOY_USER }}
|
||||||
|
DEPLOY_PATH: ${{ secrets.DEPLOY_PATH }}
|
||||||
|
DEPLOY_PASSWORD: ${{ secrets.DEPLOY_PASSWORD }}
|
||||||
|
run: |
|
||||||
|
# rsync is driven from Perl through system() with a list, so no shell ever
|
||||||
|
# parses the password, the remote path or the ssh options. The published
|
||||||
|
# set is staged into one directory and mirrored whole, because --delete
|
||||||
|
# only prunes when rsync walks a directory: a file list transfer would
|
||||||
|
# leave a script removed from the repository live on the host.
|
||||||
|
perl -e '
|
||||||
|
my $host = $ENV{DEPLOY_HOST} // die qq{ERROR: DEPLOY_HOST is unset\n};
|
||||||
|
my $user = $ENV{DEPLOY_USER} // die qq{ERROR: DEPLOY_USER is unset\n};
|
||||||
|
my $path = $ENV{DEPLOY_PATH} // die qq{ERROR: DEPLOY_PATH is unset\n};
|
||||||
|
my $pass = $ENV{DEPLOY_PASSWORD} // die qq{ERROR: DEPLOY_PASSWORD is unset\n};
|
||||||
|
my @files = sort glob q{*.pl};
|
||||||
|
@files or die qq{ERROR: no scripts found\n};
|
||||||
|
my $stage = ($ENV{HOME} // q{.}) . q{/.deploy-stage.} . $$;
|
||||||
|
mkdir($stage, 0700) or die qq{ERROR: cannot create the staging directory: $!\n};
|
||||||
|
for my $file (@files, q{SHA256SUMS}) {
|
||||||
|
system(q{cp}, q{-p}, $file, $stage) == 0
|
||||||
|
or die qq{ERROR: cannot stage $file\n};
|
||||||
|
}
|
||||||
|
# The staged files are public on the host, so the directory must stay
|
||||||
|
# traversable by nginx: rsync -a would carry 0700 over and every URL
|
||||||
|
# behind it would answer 403.
|
||||||
|
chmod(0755, $stage) or die qq{ERROR: cannot chmod the staging directory: $!\n};
|
||||||
|
print qq{Deploying to $user\@$host:$path\n};
|
||||||
|
my @cmd = (q{sshpass}, q{-p}, $pass, q{rsync}, q{-avz}, q{--delete},
|
||||||
|
q{-e}, q{ssh -o StrictHostKeyChecking=yes}, qq{$stage/},
|
||||||
|
qq{$user\@$host:$path});
|
||||||
|
system(@cmd) == 0 or die qq{ERROR: rsync failed\n};
|
||||||
|
system(q{rm}, q{-rf}, $stage) == 0
|
||||||
|
or die qq{ERROR: cannot remove the staging directory\n};
|
||||||
|
print qq{Deploy complete.\n};
|
||||||
|
'
|
||||||
@@ -0,0 +1,107 @@
|
|||||||
|
# Test: the push-path gates for the scripts collection. Runs on every push and pull
|
||||||
|
# request against development, never on main, which is release-only.
|
||||||
|
#
|
||||||
|
# The gates are the same set the repository documents in docs/DEVELOPMENT.md: every
|
||||||
|
# script compiles, carries its licence header, uses no dash as punctuation, and passes
|
||||||
|
# its own checks under tests/. They are the affordable ones: the container rigs that
|
||||||
|
# verify a script against a real system need podman and a privileged container, which
|
||||||
|
# belong to the machine at the keyboard, not to a shared runner.
|
||||||
|
#
|
||||||
|
# Every step is one command, and the scripted steps are Perl rather than shell, so no
|
||||||
|
# shell option has to be trusted for the run to stop. The Perl uses builtins only:
|
||||||
|
# the runner packages the modules separately.
|
||||||
|
name: Test
|
||||||
|
|
||||||
|
on:
|
||||||
|
push:
|
||||||
|
branches: [development]
|
||||||
|
pull_request:
|
||||||
|
branches: [development]
|
||||||
|
|
||||||
|
jobs:
|
||||||
|
test:
|
||||||
|
runs-on: fedora
|
||||||
|
timeout-minutes: 10
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v7
|
||||||
|
|
||||||
|
- name: Install Perl
|
||||||
|
run: dnf install -y perl
|
||||||
|
|
||||||
|
- name: Every script compiles
|
||||||
|
run: |
|
||||||
|
perl -e '
|
||||||
|
my @files = sort glob q{*.pl};
|
||||||
|
@files or die qq{ERROR: no scripts found\n};
|
||||||
|
for my $file (@files) {
|
||||||
|
system(q{perl}, q{-c}, $file) == 0 or die qq{ERROR: $file does not compile\n};
|
||||||
|
}
|
||||||
|
print qq{compiled @files[0..$#files]: }, scalar(@files), qq{ scripts\n};
|
||||||
|
'
|
||||||
|
|
||||||
|
- name: Every script carries the licence header
|
||||||
|
run: |
|
||||||
|
perl -e '
|
||||||
|
my @files = sort glob q{*.pl};
|
||||||
|
@files or die qq{ERROR: no scripts found\n};
|
||||||
|
for my $file (@files) {
|
||||||
|
open(my $fh, q{<}, $file) or die qq{ERROR: $file: $!\n};
|
||||||
|
my @head = map { my $line = <$fh> // q{}; chomp $line; $line } 1 .. 3;
|
||||||
|
close($fh);
|
||||||
|
$head[0] =~ m{^#!/usr/bin/env perl\z}
|
||||||
|
or die qq{ERROR: $file has no Perl shebang in the form this collection uses\n};
|
||||||
|
# The name carries a non-ASCII letter and the files are byte strings,
|
||||||
|
# so its UTF-8 bytes are matched rather than a wildcard width.
|
||||||
|
$head[1] =~ m{^# Copyright \(c\) \d{4} Petr Balv\xc3\xadn <opensource\@petrbalvin\.org> \(https://petrbalvin\.org\)\z}
|
||||||
|
or die qq{ERROR: $file has no copyright line\n};
|
||||||
|
$head[2] =~ m{^# SPDX-License-Identifier: MIT\z}
|
||||||
|
or die qq{ERROR: $file has no SPDX line, or names another licence\n};
|
||||||
|
}
|
||||||
|
print qq{licence header present in }, scalar(@files), qq{ scripts\n};
|
||||||
|
'
|
||||||
|
|
||||||
|
- name: No dash as punctuation
|
||||||
|
run: |
|
||||||
|
perl -e '
|
||||||
|
my @files = (sort(glob q{*.pl}), sort(glob q{tests/*.pl}), sort(glob q{*.md}),
|
||||||
|
sort(glob q{.gitea/workflows/*.yml}));
|
||||||
|
@files or die qq{ERROR: no files found\n};
|
||||||
|
my $found = 0;
|
||||||
|
for my $file (@files) {
|
||||||
|
open(my $fh, q{<}, $file) or die qq{ERROR: $file: $!\n};
|
||||||
|
my $number = 0;
|
||||||
|
while (my $line = <$fh>) {
|
||||||
|
$number++;
|
||||||
|
# The bytes matter: the files are byte strings, so the em dash and
|
||||||
|
# the en dash are matched as their UTF-8 sequences.
|
||||||
|
if ($line =~ /\xe2\x80\x94|\xe2\x80\x93/) {
|
||||||
|
print qq{ERROR: $file:$number uses a dash as punctuation\n};
|
||||||
|
$found++;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
close($fh);
|
||||||
|
}
|
||||||
|
die qq{ERROR: $found line(s) use a dash as punctuation\n} if $found;
|
||||||
|
print qq{no dash used as punctuation in }, scalar(@files), qq{ files\n};
|
||||||
|
'
|
||||||
|
|
||||||
|
- name: network-diag.pl
|
||||||
|
run: perl tests/network-diag.pl
|
||||||
|
|
||||||
|
- name: security-audit.pl
|
||||||
|
run: perl tests/security-audit.pl
|
||||||
|
|
||||||
|
- name: server-setup.pl
|
||||||
|
run: perl tests/server-setup.pl
|
||||||
|
|
||||||
|
- name: sglang-deploy.pl
|
||||||
|
run: perl tests/sglang-deploy.pl
|
||||||
|
|
||||||
|
- name: system-diag.pl
|
||||||
|
run: perl tests/system-diag.pl
|
||||||
|
|
||||||
|
- name: system-optimise.pl
|
||||||
|
run: perl tests/system-optimise.pl
|
||||||
|
|
||||||
|
- name: workstation-setup.pl
|
||||||
|
run: perl tests/workstation-setup.pl
|
||||||
@@ -0,0 +1,5 @@
|
|||||||
|
.idea/
|
||||||
|
.zcode/
|
||||||
|
|
||||||
|
# Generated by CI, deployed alongside the scripts
|
||||||
|
SHA256SUMS
|
||||||
+114
@@ -0,0 +1,114 @@
|
|||||||
|
# Contributing
|
||||||
|
|
||||||
|
Thanks for contributing to **scripts**.
|
||||||
|
|
||||||
|
## Development setup
|
||||||
|
|
||||||
|
Requirements: Perl 5.38 or newer, which is what the oldest supported system ships
|
||||||
|
(CentOS Stream 10 carries 5.40, openEuler 24.03 LTS carries 5.38). No module beyond the
|
||||||
|
interpreter is needed, by design: the scripts use builtins only. Podman is needed only
|
||||||
|
for the container rigs described in [docs/DEVELOPMENT.md](docs/DEVELOPMENT.md).
|
||||||
|
|
||||||
|
```sh
|
||||||
|
git clone https://sourcedock.dev/petrbalvin/scripts.git
|
||||||
|
cd scripts
|
||||||
|
perl -c network-diag.pl
|
||||||
|
perl tests/network-diag.pl
|
||||||
|
```
|
||||||
|
|
||||||
|
## Workflow
|
||||||
|
|
||||||
|
1. Branch from `development`. Never commit directly to `main`, which is release-only.
|
||||||
|
2. Commit in [Conventional Commits](https://www.conventionalcommits.org/) form:
|
||||||
|
`type(scope): description`, subject line only, imperative mood, lowercase after the
|
||||||
|
colon, no trailing full stop. Allowed types: `feat`, `fix`, `docs`, `style`,
|
||||||
|
`refactor`, `perf`, `test`, `chore`, `ci`, `build`, `revert`.
|
||||||
|
3. One logical change per commit. A refactor, a behaviour change and a formatting pass
|
||||||
|
are three commits, never one.
|
||||||
|
4. Add or extend the checks in `tests/` for the code you touched. A new script arrives
|
||||||
|
with its own `tests/<script>.pl`.
|
||||||
|
5. Update the documentation when the flags, the behaviour or the target systems change.
|
||||||
|
6. Open a pull request against `development`.
|
||||||
|
|
||||||
|
`main` is not a release branch in the usual sense: the deploy pipeline publishes the
|
||||||
|
scripts on every push to it, so a merge to `main` is a release. The scripts carry their
|
||||||
|
own versions, and the commit history is the record of what changed.
|
||||||
|
|
||||||
|
## Code style
|
||||||
|
|
||||||
|
There is no formatter to run, and the style is the one the other scripts already share.
|
||||||
|
Read the script nearest to your change and follow it.
|
||||||
|
|
||||||
|
- **Builtins only.** No `use` beyond `strict` and `warnings`. A job Perl has no builtin
|
||||||
|
for is either written out in the script (the command runner, version comparison, the
|
||||||
|
JSON codecs, IPv4 and IPv6 arithmetic) or delegated to a system binary through the
|
||||||
|
script's `run` helper, which is how `dnf`, `rpm`, `curl`, `openssl`, `podman`,
|
||||||
|
`systemctl` and the rest are driven.
|
||||||
|
- **Every external command is one argument list.** `run([...])` never builds a string,
|
||||||
|
so no shell parses a path, a key or a URL.
|
||||||
|
- **Idempotence is the contract.** Every operation checks the current state first and
|
||||||
|
reports what it found; running a script twice must change nothing the second time.
|
||||||
|
- **`--dry-run` changes nothing**, and the summary of a dry run reads as a preview, not
|
||||||
|
as an accomplishment.
|
||||||
|
- **Messages are in British English, on stderr**, and none of them uses a dash as
|
||||||
|
punctuation.
|
||||||
|
- `perl -c <script>` must be clean, and so must `perl tests/<script>.pl`.
|
||||||
|
- New files open with the shebang `#!/usr/bin/env perl`, then the two-line licence
|
||||||
|
header whose SPDX identifier matches [LICENSE](LICENSE).
|
||||||
|
|
||||||
|
The gates are listed in [docs/DEVELOPMENT.md](docs/DEVELOPMENT.md), and the test
|
||||||
|
pipeline runs the same set.
|
||||||
|
|
||||||
|
## AI contribution policy
|
||||||
|
|
||||||
|
AI tools are welcome as productivity aids and are a normal part of modern software
|
||||||
|
development. What matters is that the contribution stays understandable, reviewable and
|
||||||
|
genuinely useful.
|
||||||
|
|
||||||
|
- **Disclose the assistance.** If AI helped draft any part of a commit, issue, pull
|
||||||
|
request or review, say so.
|
||||||
|
- **Commit messages carry exactly one trailer**, on the line after the subject:
|
||||||
|
|
||||||
|
```
|
||||||
|
Assisted-by: MODEL
|
||||||
|
```
|
||||||
|
|
||||||
|
Name the model that did the work, spelled the way its maker spells it, for example
|
||||||
|
`GLM 5.3`, `DeepSeek V4.1 Flash` or `Qwen 3.8 Flash`. No `Co-Authored-By`, no
|
||||||
|
`Signed-off-by`, no other trailers, and no prose: the trailer is the disclosure.
|
||||||
|
- **Issues and pull requests** attribute the assistance in a comment, for example
|
||||||
|
`_Assisted-by: GLM 5.3_`. It does not belong in the pull request description.
|
||||||
|
- **Take responsibility.** You are accountable for the accuracy, completeness and
|
||||||
|
intent of everything you submit, whether or not AI produced it.
|
||||||
|
- **Review before marking ready.** Read the diff carefully, run it locally, and add the
|
||||||
|
tests it needs. Do not mark a pull request ready until you can defend every change in
|
||||||
|
it.
|
||||||
|
- **Quality over quantity.** Contributions that look like un-reviewed output, or whose
|
||||||
|
author cannot engage substantively during review, may be closed.
|
||||||
|
- **Preferred models.** Prefer open-weight models with transparent training data and
|
||||||
|
minimal output filtering.
|
||||||
|
|
||||||
|
AI assists. It does not replace judgement.
|
||||||
|
|
||||||
|
## Continuous integration
|
||||||
|
|
||||||
|
Workflows live in `.gitea/workflows/` and run on the project's own runners:
|
||||||
|
|
||||||
|
| Workflow | Trigger | What it does |
|
||||||
|
|---|---|---|
|
||||||
|
| Test | push or pull request to `development` | every script compiles, carries its licence header and uses no dash as punctuation, then the six check files under `tests/` |
|
||||||
|
| Deploy | push to `main` | writes `SHA256SUMS` over every script and publishes them over rsync |
|
||||||
|
|
||||||
|
The container rigs are not in the pipeline: they need Podman and a privileged
|
||||||
|
container, which belong to the machine at the keyboard rather than to a shared runner.
|
||||||
|
A change to a script that touches a system is expected to be verified that way locally,
|
||||||
|
and the pull request says what was run.
|
||||||
|
|
||||||
|
## Reporting bugs
|
||||||
|
|
||||||
|
Open an issue at `https://sourcedock.dev/petrbalvin/scripts/issues` with the script and
|
||||||
|
its version (the script's `--version`), the operating system and version, the exact
|
||||||
|
command, the full output, and the expected against the actual behaviour.
|
||||||
|
|
||||||
|
**Security issues do not go in the issue tracker.** Report them as
|
||||||
|
[SECURITY.md](SECURITY.md) describes.
|
||||||
@@ -0,0 +1,21 @@
|
|||||||
|
MIT License
|
||||||
|
|
||||||
|
Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||||||
|
|
||||||
|
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||||
|
of this software and associated documentation files (the "Software"), to deal
|
||||||
|
in the Software without restriction, including without limitation the rights
|
||||||
|
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||||
|
copies of the Software, and to permit persons to whom the Software is
|
||||||
|
furnished to do so, subject to the following conditions:
|
||||||
|
|
||||||
|
The above copyright notice and this permission notice shall be included in all
|
||||||
|
copies or substantial portions of the Software.
|
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||||
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||||
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||||
|
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||||
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||||
|
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||||
|
SOFTWARE.
|
||||||
@@ -0,0 +1,126 @@
|
|||||||
|
# Scripts: DevOps Toolbox
|
||||||
|
|
||||||
|
A personal collection of standalone scripts for Linux server and desktop management:
|
||||||
|
diagnostics, first-time server and workstation setup, routine cleanup, and an
|
||||||
|
inference server deployment. Every script is Perl, every one runs on the interpreter's
|
||||||
|
own builtins, and none of them needs a module installed beside it.
|
||||||
|
|
||||||
|
## Features
|
||||||
|
|
||||||
|
- **Diagnostics**: `network-diag.pl` measures latency, packet loss, DNS resolution,
|
||||||
|
MTU and dual-stack reachability and grades the connection; `system-diag.pl` reads
|
||||||
|
the whole machine (CPU, memory, disk, network, GPU, services, security, performance)
|
||||||
|
and grades its health.
|
||||||
|
- **Security audit**: `security-audit.pl` grades the machine's defences A to F from the
|
||||||
|
state it is actually in: the effective sshd configuration, the running firewalld
|
||||||
|
checked against the sockets that really listen, SELinux now and at the next boot,
|
||||||
|
pending security updates, accounts and sudo, kernel hardening, and an opt-in deep
|
||||||
|
scan of the file system. A critical finding is a non-zero exit, so a cron job fails
|
||||||
|
loudly.
|
||||||
|
- **Setup**: `server-setup.pl` takes a fresh server to a working state (packages,
|
||||||
|
firewall with the SSH rule verified before the service is enabled, SELinux, Podman,
|
||||||
|
automatic updates); `workstation-setup.pl` sets up a Fedora desktop (Brave, the
|
||||||
|
official Go toolchain, Rust, GoLand, Flatpak applications, firewall, SELinux).
|
||||||
|
- **Deployment**: `sglang-deploy.pl` puts an SGLang inference server on an AMD GPU
|
||||||
|
behind nginx with HTTPS and an API key, runs the engine from the project's ROCm
|
||||||
|
container image, and downloads the model weights from ModelScope.
|
||||||
|
- **Maintenance**: `system-optimise.pl` removes old kernels (the running one and one
|
||||||
|
fallback always stay), vacuums journals, clears temporary files and core dumps, and
|
||||||
|
audits the installed packages against their repositories.
|
||||||
|
- **Idempotent by construction**: every operation checks the current state before
|
||||||
|
acting, so a second run reports what is already in place and changes nothing.
|
||||||
|
|
||||||
|
## Install
|
||||||
|
|
||||||
|
The scripts are single files. Take the repository, or take one script with `curl`:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
git clone https://sourcedock.dev/petrbalvin/scripts.git
|
||||||
|
cd scripts
|
||||||
|
```
|
||||||
|
|
||||||
|
Requirements: Perl, which every supported system ships. Nothing else: the scripts
|
||||||
|
drive the system's own tools (`dnf`, `systemctl`, `podman`, `openssl`, `curl`) rather
|
||||||
|
than carrying a library layer, and where a language has no builtin for a job the
|
||||||
|
script does the work itself.
|
||||||
|
|
||||||
|
## Quick start
|
||||||
|
|
||||||
|
```sh
|
||||||
|
# Network diagnostics, no root needed
|
||||||
|
perl network-diag.pl
|
||||||
|
|
||||||
|
# System health, no root needed
|
||||||
|
perl system-diag.pl
|
||||||
|
|
||||||
|
# Security audit, deeper answers as root
|
||||||
|
sudo perl security-audit.pl --deep
|
||||||
|
|
||||||
|
# Server setup, as root
|
||||||
|
sudo perl server-setup.pl --dry-run
|
||||||
|
|
||||||
|
# SGLang on an AMD GPU, as root
|
||||||
|
sudo perl sglang-deploy.pl --model ZhipuAI/GLM-5.3
|
||||||
|
```
|
||||||
|
|
||||||
|
Any script can also be fetched and run in one step:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
curl -sSf https://petrbalvin.org/scripts/system-diag.pl | perl
|
||||||
|
```
|
||||||
|
|
||||||
|
#### Integrity verification
|
||||||
|
|
||||||
|
A single `SHA256SUMS` file covers every published script. Verify before running:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
curl -sSfO https://petrbalvin.org/scripts/server-setup.pl
|
||||||
|
curl -sSfO https://petrbalvin.org/scripts/SHA256SUMS
|
||||||
|
sha256sum -c --ignore-missing SHA256SUMS
|
||||||
|
sudo perl server-setup.pl --dry-run
|
||||||
|
```
|
||||||
|
|
||||||
|
## Usage
|
||||||
|
|
||||||
|
Each script documents its own flags; `--help` prints them and `--dry-run` shows what
|
||||||
|
a change would do without doing it.
|
||||||
|
|
||||||
|
| Script | Version | Purpose |
|
||||||
|
|---|---|---|
|
||||||
|
| `network-diag.pl` | 2.0.0 | Network latency, DNS, MTU, packet loss and dual-stack on Linux and FreeBSD |
|
||||||
|
| `system-diag.pl` | 2.0.0 | System health with a grade from A to F. Linux only |
|
||||||
|
| `security-audit.pl` | 2.0.0 | Security posture with a grade from A to F and an exit code for cron. Linux only |
|
||||||
|
| `server-setup.pl` | 2.0.0 | Server initial setup for Fedora, CentOS Stream and openEuler |
|
||||||
|
| `workstation-setup.pl` | 2.0.0 | Fedora desktop setup |
|
||||||
|
| `sglang-deploy.pl` | 2.0.0 | SGLang inference server on an AMD GPU, behind nginx with HTTPS |
|
||||||
|
| `system-optimise.pl` | 2.0.0 | System cleanup; refuses rpm-ostree systems |
|
||||||
|
|
||||||
|
The full flag reference is in [docs/CLI.md](docs/CLI.md).
|
||||||
|
|
||||||
|
## Development
|
||||||
|
|
||||||
|
```sh
|
||||||
|
perl -c network-diag.pl # every script compiles
|
||||||
|
perl tests/network-diag.pl # that script's checks
|
||||||
|
perl tests/system-diag.pl # and so on for each script
|
||||||
|
```
|
||||||
|
|
||||||
|
The local gates are the syntax check, the seven test files, the licence header and the
|
||||||
|
punctuation rule; the container rigs that verify a script against a real system are
|
||||||
|
described in [docs/DEVELOPMENT.md](docs/DEVELOPMENT.md). See
|
||||||
|
[CONTRIBUTING.md](CONTRIBUTING.md) for how to contribute.
|
||||||
|
|
||||||
|
## Documentation
|
||||||
|
|
||||||
|
- [docs/ARCHITECTURE.md](docs/ARCHITECTURE.md): the shared shape of the scripts and
|
||||||
|
what each one owns
|
||||||
|
- [docs/CLI.md](docs/CLI.md): every flag of every script
|
||||||
|
- [docs/DEPLOYMENT.md](docs/DEPLOYMENT.md): how the scripts are published, and what
|
||||||
|
they deploy on a host
|
||||||
|
- [docs/DEVELOPMENT.md](docs/DEVELOPMENT.md): prerequisites, commands and verification
|
||||||
|
|
||||||
|
## Licence
|
||||||
|
|
||||||
|
MIT. See [LICENSE](LICENSE).
|
||||||
|
|
||||||
|
Copyright © 2026 [Petr Balvín](https://petrbalvin.org)
|
||||||
+69
@@ -0,0 +1,69 @@
|
|||||||
|
# Security policy
|
||||||
|
|
||||||
|
## Supported versions
|
||||||
|
|
||||||
|
The published scripts are not versioned artefacts: `https://petrbalvin.org/scripts/` is
|
||||||
|
updated on every push to `main`, and each script carries its own version string. A
|
||||||
|
security fix goes to the newest published copy and to the `development` branch of the
|
||||||
|
repository. Older copies that were downloaded earlier do not receive fixes; take the
|
||||||
|
current file again.
|
||||||
|
|
||||||
|
`SHA256SUMS` is published beside the scripts and covers every one of them, so a
|
||||||
|
downloaded copy can be checked before it runs:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
curl -sSfO https://petrbalvin.org/scripts/server-setup.pl
|
||||||
|
curl -sSfO https://petrbalvin.org/scripts/SHA256SUMS
|
||||||
|
sha256sum -c --ignore-missing SHA256SUMS
|
||||||
|
```
|
||||||
|
|
||||||
|
## Reporting a vulnerability
|
||||||
|
|
||||||
|
**Do not open a public issue for a security problem.** A public report tells everyone
|
||||||
|
about the flaw before there is a fix. Report it privately to
|
||||||
|
**opensource@petrbalvin.org**.
|
||||||
|
|
||||||
|
Include:
|
||||||
|
|
||||||
|
- the script and its version (`--version`), and the platform
|
||||||
|
- what the problem is, and what an attacker gains from it
|
||||||
|
- the smallest reproducer you have, ideally a single command
|
||||||
|
- a suggested fix, if you have one
|
||||||
|
|
||||||
|
## What to expect
|
||||||
|
|
||||||
|
- A human reads the report, and you get an acknowledgement.
|
||||||
|
- You are kept informed while the fix is being made, and told when it ships.
|
||||||
|
- The fix is published before the details are, and the timing is agreed with you.
|
||||||
|
- You are credited in the commit message of the fix, by name or by handle, as you
|
||||||
|
prefer.
|
||||||
|
|
||||||
|
## What the scripts already do
|
||||||
|
|
||||||
|
These are the properties to check first, because a finding that contradicts one of them
|
||||||
|
is a defect worth reporting:
|
||||||
|
|
||||||
|
- `server-setup.pl` writes the SSH rule into the permanent firewalld configuration and
|
||||||
|
verifies it through the offline client **before** firewalld is enabled, so enabling
|
||||||
|
the firewall cannot lock the operator out.
|
||||||
|
- `sglang-deploy.pl` protects the endpoint with an API key stored in a root-only
|
||||||
|
`EnvironmentFile` (`/etc/sysconfig/sglang`, mode 0600), serves it over TLS only, and
|
||||||
|
binds the engine to the loopback address.
|
||||||
|
- `workstation-setup.pl` verifies what it downloads: the Go tarball against the SHA-256
|
||||||
|
in go.dev's download API, the GoLand tarball against JetBrains' published checksum,
|
||||||
|
and Brave's repository key against the fingerprints published on brave.com.
|
||||||
|
- Downloads are never piped into a shell: a fetched installer lands in a file first and
|
||||||
|
is executed only after the transfer completed.
|
||||||
|
|
||||||
|
## Out of scope
|
||||||
|
|
||||||
|
- Findings that require the attacker to already have root, or to already run code as the
|
||||||
|
user who runs the script.
|
||||||
|
- Missing hardening with no demonstrated impact, such as a script not setting a stricter
|
||||||
|
umask than the system's.
|
||||||
|
- Flaws in a third-party tool the scripts drive (`dnf`, `podman`, `openssl`, `nginx` and
|
||||||
|
the rest): report those to that project, and here only when this repository's use of
|
||||||
|
the tool makes the flaw reachable in a way the tool's own documentation does not
|
||||||
|
anticipate.
|
||||||
|
- The published copies being fetched over HTTPS from a domain the operator does not
|
||||||
|
control, which is the deployment model rather than a defect in the scripts.
|
||||||
@@ -0,0 +1,128 @@
|
|||||||
|
# Architecture
|
||||||
|
|
||||||
|
How the scripts collection is put together. Every script, helper and arrow below
|
||||||
|
exists in the repository; nothing is aspirational.
|
||||||
|
|
||||||
|
## Overview
|
||||||
|
|
||||||
|
There is no shared library. Each script is one file that can be fetched and run on its
|
||||||
|
own, and the six of them share a skeleton rather than a module: the same command
|
||||||
|
runner, the same progress reporting, the same state checks before every action, and the
|
||||||
|
same shape of a run.
|
||||||
|
|
||||||
|
```mermaid
|
||||||
|
flowchart TD
|
||||||
|
Start[invocation] --> Args[parse_args reads ARGV]
|
||||||
|
Args --> Version{version or help?}
|
||||||
|
Version -->|yes| Print[print and exit]
|
||||||
|
Version -->|no| Root[check_root, detect_os]
|
||||||
|
Root --> Sections[sections run in order]
|
||||||
|
Sections --> Each[each section checks state first]
|
||||||
|
Each --> Done{changed?}
|
||||||
|
Done -->|no| Report[report what is already in place]
|
||||||
|
Done -->|yes| Act[act, then verify what was done]
|
||||||
|
Act --> Report
|
||||||
|
Report --> Summary[print_summary on stderr]
|
||||||
|
```
|
||||||
|
|
||||||
|
A run is idempotent because of that loop: a section reads the state of the system,
|
||||||
|
compares it with the desired one, and acts only on the difference, so a second run
|
||||||
|
reports everything as already in place and changes nothing.
|
||||||
|
|
||||||
|
## The seven scripts
|
||||||
|
|
||||||
|
| Script | Owns | Deliberately does not |
|
||||||
|
|---|---|---|
|
||||||
|
| `network-diag.pl` | Latency, loss, DNS timing, MTU discovery, dual-stack reachability, listening ports, and the grade of the connection | Touch any configuration; it only measures |
|
||||||
|
| `system-diag.pl` | Reading CPU, memory, disk, network, GPU, services, security and performance, and grading the result | Change anything on the host; it is read-only |
|
||||||
|
| `server-setup.pl` | Base packages, firewall (with the SSH rule verified before the service starts), SELinux, Podman, automatic updates | Install the services themselves; that is the operator's, and the deploy scripts' |
|
||||||
|
| `workstation-setup.pl` | A Fedora desktop: Brave, the official Go toolchain, Rust, GoLand, Flatpak applications, firewall, SELinux | Anything on a server distribution; it targets Fedora Workstation |
|
||||||
|
| `sglang-deploy.pl` | The SGLang deployment: the container engine, the systemd unit, nginx with TLS, the API key, the firewall rule and the SELinux boolean | The host's own setup, which `server-setup.pl` does first |
|
||||||
|
| `system-optimise.pl` | Old kernels (the running one and one fallback always stay), journals, temporary files, core dumps, and the package audit | Touch an rpm-ostree system, which it refuses |
|
||||||
|
|
||||||
|
## Data flow: a forked section collection
|
||||||
|
|
||||||
|
`system-diag.pl` is the one script whose shape is not linear. Its sections are
|
||||||
|
independent and dominated by waiting, so each runs in its own child process, writes its
|
||||||
|
result into a private scratch directory as a Perl literal, and the parent reads the
|
||||||
|
results back after reaping. The runner keeps stdout and stderr apart in that same
|
||||||
|
directory, which is why the file names carry the process id.
|
||||||
|
|
||||||
|
```mermaid
|
||||||
|
sequenceDiagram
|
||||||
|
participant Parent
|
||||||
|
participant Child as Section child
|
||||||
|
participant Disk as Scratch directory
|
||||||
|
Parent->>Child: fork, one per requested section
|
||||||
|
Child->>Child: collect one section
|
||||||
|
Child->>Disk: write the result as a Perl literal
|
||||||
|
Parent->>Parent: waitpid, report the section as it lands
|
||||||
|
Parent->>Disk: read_literal for each child
|
||||||
|
Parent->>Parent: compute the grade and render the report
|
||||||
|
Parent->>Disk: remove the scratch directory
|
||||||
|
```
|
||||||
|
|
||||||
|
Only the process that created the scratch directory removes it: a forked child inherits
|
||||||
|
the `END` block, so the cleanup is guarded by a parent pid comparison. A child that
|
||||||
|
cannot write its result is reported as a missing section, and the grade drops that
|
||||||
|
component rather than inventing a value for it.
|
||||||
|
|
||||||
|
## Conventions every script follows
|
||||||
|
|
||||||
|
- **Builtins only.** No module beyond the interpreter is loaded, because the systems
|
||||||
|
this targets package modules separately. What Perl has no builtin for is written out:
|
||||||
|
the command runner, RPM's version comparison, the JSON decoders and the encoder, the
|
||||||
|
IPv4 and IPv6 arithmetic, `sockaddr` packing, a `which`, and argument parsing.
|
||||||
|
- **External binaries as transport.** `dnf`, `rpm`, `curl`, `openssl`, `podman`,
|
||||||
|
`systemctl`, `journalctl`, `find`, `stat`, `sha256sum`, `tar`, `gpg`, `lspci` and the
|
||||||
|
rest are driven as argument lists through `run`, which keeps stdout and stderr apart,
|
||||||
|
forces `LANG=C` and `LC_ALL=C` for parseable output, and turns a timeout, a missing
|
||||||
|
binary and a failed exec into exit codes 124, 127 and 126 rather than exceptions.
|
||||||
|
- **One optional module.** `Time::HiRes` is loaded inside an `eval` in the scripts that
|
||||||
|
time something. Where it is absent the affected figures are reported as not measured
|
||||||
|
and the grade drops that component, rather than the script failing.
|
||||||
|
- **Atomic writes for system configuration.** A file that a boot depends on is written
|
||||||
|
to a temporary name, flushed, given its mode and owner, and renamed over the target.
|
||||||
|
Perl has no `fsync`, so that barrier is delegated to `sync` where the binary exists.
|
||||||
|
- **Errors carry what the tool said.** A failure reproduces the errno, the reason and
|
||||||
|
the path, so a message can be searched for as it stands.
|
||||||
|
|
||||||
|
## The SGLang deployment
|
||||||
|
|
||||||
|
`sglang-deploy.pl` is the only script that deploys a service, and its engine runs as a
|
||||||
|
container. That is a consequence of the material rather than a preference: SGLang
|
||||||
|
publishes no ROCm wheel, and its AMD install paths are the project's container images
|
||||||
|
or a source build against a full ROCm toolchain that Fedora carries only partly and
|
||||||
|
that CentOS Stream and openEuler cannot carry at all.
|
||||||
|
|
||||||
|
```mermaid
|
||||||
|
flowchart LR
|
||||||
|
Client[client] -->|443| Nginx[nginx on the host, TLS]
|
||||||
|
Nginx -->|loopback, plain HTTP| Engine[SGLang in a Podman container]
|
||||||
|
Engine -->|device nodes| GPU[/dev/kfd, /dev/dri]
|
||||||
|
Engine -->|bind mount| Cache[state directory, model cache]
|
||||||
|
Unit[systemd unit] -->|podman run| Engine
|
||||||
|
EnvFile[EnvironmentFile, mode 0600] -->|API key| Unit
|
||||||
|
```
|
||||||
|
|
||||||
|
The host therefore needs the amdgpu kernel driver and its device nodes, never a ROCm
|
||||||
|
userland. The image tag is resolved from the card's family (mi30x for an MI300 or
|
||||||
|
MI325, mi35x for an MI350 or MI355) and from the host's ROCm, because the container's
|
||||||
|
ROCm userland must not be newer than the host's kernel driver. A Radeon 8060S or 8050S
|
||||||
|
(gfx1151) has no stable tag anywhere; AMD's dated development builds are resolved
|
||||||
|
instead, and `--image` pins one. Radeon cards need `SGLANG_USE_AITER=false` and
|
||||||
|
`SGLANG_ROCM_FUSED_DECODE_MLA=false` in the unit, which the script writes for them and
|
||||||
|
never for an Instinct host.
|
||||||
|
|
||||||
|
## Dependencies
|
||||||
|
|
||||||
|
Nothing outside the interpreter, and nothing that has to be installed beyond the tools
|
||||||
|
each script's own dependency section installs. The non-obvious ones and their reasons:
|
||||||
|
|
||||||
|
- `podman` for `sglang-deploy.pl`, because the engine is a container.
|
||||||
|
- `lspci` for the GPU family, and `rocm-smi` in `system-diag.pl` for AMD memory and
|
||||||
|
utilisation figures.
|
||||||
|
- `sha256sum` in `workstation-setup.pl`, because Perl's builtins have no hash.
|
||||||
|
- `sync` for the write barrier after an atomic write.
|
||||||
|
- `getent` or `host` in `network-diag.pl` as the resolver transport, since `getent` on
|
||||||
|
FreeBSD implements neither of the `ahosts` databases.
|
||||||
+197
@@ -0,0 +1,197 @@
|
|||||||
|
# Command line
|
||||||
|
|
||||||
|
Every script is its own program, and there is no global command. The reference below is
|
||||||
|
taken from each script's own `--help`; if the two disagree, the program is right and
|
||||||
|
this file is a defect.
|
||||||
|
|
||||||
|
Common to all six: `--version` prints the version and exits, `-h` / `--help` prints the
|
||||||
|
usage and exits, options are given as `--name value` or `--name=value`, and an unknown
|
||||||
|
option is refused with the usage and exit code 2.
|
||||||
|
|
||||||
|
## network-diag.pl
|
||||||
|
|
||||||
|
```
|
||||||
|
Usage: network-diag.pl [options]
|
||||||
|
|
||||||
|
Network diagnostics: latency, DNS, MTU, dual-stack, ports
|
||||||
|
|
||||||
|
Options:
|
||||||
|
--target HOST Target host for tests (default: cloudflare.com)
|
||||||
|
--protocol FAMILY Address family: auto (dual-stack), v4 (IPv4 only),
|
||||||
|
v6 (IPv6 only) (default: auto)
|
||||||
|
--version Show the version and exit
|
||||||
|
-h, --help Show this help and exit
|
||||||
|
```
|
||||||
|
|
||||||
|
| Flag | Default | Effect |
|
||||||
|
|---|---|---|
|
||||||
|
| `--target HOST` | `cloudflare.com` | The host pinged, resolved and probed for MTU |
|
||||||
|
| `--protocol FAMILY` | `auto` | `auto` measures both families, `v4` and `v6` restrict the run |
|
||||||
|
|
||||||
|
Runs without root. Ports belonging to other users are reported as `(no permission)`
|
||||||
|
rather than silently dropped.
|
||||||
|
|
||||||
|
## system-diag.pl
|
||||||
|
|
||||||
|
```
|
||||||
|
Usage: system-diag.pl [options]
|
||||||
|
|
||||||
|
System diagnostics: CPU, memory, disk, network, GPU, services, security, performance
|
||||||
|
|
||||||
|
Options:
|
||||||
|
--section LIST Comma-separated sections to run. Available: overview, cpu, memory, disk, network, gpu, services, security, performance, issues [default: all]
|
||||||
|
--external-ip Also detect external IP addresses via icanhazip.com (sends a request to a third-party service)
|
||||||
|
--json Output machine-readable JSON to stdout
|
||||||
|
--version Show the version and exit
|
||||||
|
-h, --help Show this help and exit
|
||||||
|
```
|
||||||
|
|
||||||
|
| Flag | Default | Effect |
|
||||||
|
|---|---|---|
|
||||||
|
| `--section LIST` | all | Runs only the named sections |
|
||||||
|
| `--external-ip` | off | Sends a request to `icanhazip.com` to report the public address |
|
||||||
|
| `--json` | off | Writes the JSON document to stdout instead of the report |
|
||||||
|
|
||||||
|
Runs without root; some figures need it and are reported as unavailable instead. Colour
|
||||||
|
is used only on a terminal and is suppressed by `NO_COLOR`. The report goes to stderr,
|
||||||
|
so `--json` keeps stdout clean.
|
||||||
|
|
||||||
|
## server-setup.pl
|
||||||
|
|
||||||
|
```
|
||||||
|
Usage: server-setup.pl [options]
|
||||||
|
|
||||||
|
Idempotent server setup for Fedora Server, CentOS Stream and openEuler
|
||||||
|
|
||||||
|
Options:
|
||||||
|
--dry-run Print what would be done without making changes
|
||||||
|
--skip-update Skip system update
|
||||||
|
--skip-packages Skip base package installation
|
||||||
|
--skip-epel Skip EPEL repository setup on CentOS
|
||||||
|
--skip-firewall Skip firewall setup
|
||||||
|
--skip-selinux Skip SELinux configuration
|
||||||
|
--skip-podman Skip Podman installation
|
||||||
|
--skip-auto-updates Skip automatic updates configuration
|
||||||
|
--version Show the version and exit
|
||||||
|
-h, --help Show this help and exit
|
||||||
|
```
|
||||||
|
|
||||||
|
Needs root. The `--skip-*` flags exist per section so a section can be left to another
|
||||||
|
tool; the sections are ordered update, EPEL, packages, firewall, SELinux, Podman,
|
||||||
|
automatic updates.
|
||||||
|
|
||||||
|
## workstation-setup.pl
|
||||||
|
|
||||||
|
```
|
||||||
|
Usage: workstation-setup.pl [options]
|
||||||
|
|
||||||
|
Idempotent workstation setup for Fedora
|
||||||
|
|
||||||
|
Options:
|
||||||
|
--dry-run Print what would be done without making changes
|
||||||
|
--skip-update Skip system update
|
||||||
|
--skip-rpm Skip RPM package installation
|
||||||
|
--skip-flatpak Skip Flatpak apps
|
||||||
|
--skip-repos Skip adding third-party repos
|
||||||
|
--skip-remove Skip removing pre-installed apps
|
||||||
|
--skip-go Skip Go toolchain installation
|
||||||
|
--skip-rust Skip Rust toolchain installation
|
||||||
|
--skip-jetbrains Skip JetBrains IDE installation
|
||||||
|
--skip-firewall Skip firewall setup
|
||||||
|
--skip-selinux Skip SELinux setup
|
||||||
|
--version Show the version and exit
|
||||||
|
-h, --help Show this help and exit
|
||||||
|
```
|
||||||
|
|
||||||
|
Needs root, and targets Fedora only. The Go toolchain and GoLand are downloaded and
|
||||||
|
verified by checksum; Brave's repository key is verified by fingerprint before import.
|
||||||
|
|
||||||
|
## sglang-deploy.pl
|
||||||
|
|
||||||
|
```
|
||||||
|
Usage: sglang-deploy.pl [options]
|
||||||
|
|
||||||
|
--model ID Hugging Face model ID (menu when omitted)
|
||||||
|
--port N internal engine port (default: 8000, not 443)
|
||||||
|
--tensor-parallel N GPUs for tensor parallelism (default: 1, written as
|
||||||
|
the engine's --tp-size)
|
||||||
|
--max-model-len N context length (default: 4096, written as the
|
||||||
|
engine's --context-length)
|
||||||
|
--gpu-memory-utilization F static memory fraction (default: 0.90, written as
|
||||||
|
the engine's --mem-fraction-static)
|
||||||
|
--state-dir PATH state and model cache directory (default: /opt/sglang)
|
||||||
|
--service-name NAME systemd service name (default: sglang)
|
||||||
|
--cert-dir PATH TLS certificate directory (default: /etc/ssl/sglang)
|
||||||
|
--image TAG engine image (default: resolved from the GPU and
|
||||||
|
the newest SGLang release; a Radeon card resolves
|
||||||
|
AMD's newest dated gfx1151 build)
|
||||||
|
--rocm-flavour NAME ROCm flavour of the image (default: from the host
|
||||||
|
ROCm; rocm10, rocm724, rocm720 or rocm700)
|
||||||
|
--api-key KEY API key for the endpoint (default: generate and
|
||||||
|
store in /etc/sysconfig)
|
||||||
|
--dry-run preview without making changes
|
||||||
|
--uninstall tear down the service, container, nginx config
|
||||||
|
and certificates
|
||||||
|
--help show this help
|
||||||
|
--version show the version
|
||||||
|
```
|
||||||
|
|
||||||
|
Needs root. Without `--model` an interactive menu offers GLM 5.3, GLM 5.3 Flash,
|
||||||
|
DeepSeek V4 Pro, DeepSeek V4 Flash, MiMo V2.5 Pro and MiMo V2.5, plus a free-form
|
||||||
|
entry. `--tensor-parallel`, `--max-model-len` and `--gpu-memory-utilization` are
|
||||||
|
written to the unit as the engine's own `--tp-size`, `--context-length` and
|
||||||
|
`--mem-fraction-static`. The API key is shown once when it is generated; a key given
|
||||||
|
with `--api-key` is never echoed. `--uninstall` stops and disables the service, removes
|
||||||
|
the unit, the container, the nginx configuration and the certificates, and keeps the
|
||||||
|
image and the model cache.
|
||||||
|
|
||||||
|
## system-optimise.pl
|
||||||
|
|
||||||
|
```
|
||||||
|
Usage: system-optimise.pl [options]
|
||||||
|
|
||||||
|
Idempotent system cleanup and optimisation for Fedora, CentOS Stream and openEuler
|
||||||
|
|
||||||
|
Options:
|
||||||
|
--dry-run Preview without making changes
|
||||||
|
--skip-dnf Skip DNF cleanup (autoremove, old kernels, cache)
|
||||||
|
--skip-journal Skip journal vacuum
|
||||||
|
--skip-tmp Skip temp file cleanup
|
||||||
|
--skip-cores Skip core dump cleanup
|
||||||
|
--version Show the version and exit
|
||||||
|
-h, --help Show this help and exit
|
||||||
|
```
|
||||||
|
|
||||||
|
Needs root. The running kernel and one fallback are always kept. Both dnf generations
|
||||||
|
are driven: Fedora ships dnf 5, CentOS Stream 10 and openEuler ship dnf 4.
|
||||||
|
|
||||||
|
## Exit codes
|
||||||
|
|
||||||
|
| Code | Meaning |
|
||||||
|
|---|---|
|
||||||
|
| `0` | The run completed, and every step it attempted succeeded |
|
||||||
|
| `1` | A step failed, a required tool is missing, the hardware does not qualify, or the system is unsupported |
|
||||||
|
| `2` | The arguments were wrong, or interactive input was needed and stdin is not a terminal |
|
||||||
|
|
||||||
|
A run that finishes with failed steps prints them at the end of the summary and exits 1,
|
||||||
|
so a pipeline notices even when the failure was not fatal.
|
||||||
|
|
||||||
|
## Examples
|
||||||
|
|
||||||
|
```sh
|
||||||
|
# Is the connection healthy, and is IPv6 working?
|
||||||
|
perl network-diag.pl --target example.org --protocol auto
|
||||||
|
|
||||||
|
# The same machine's health as JSON, for a monitoring poll
|
||||||
|
perl system-diag.pl --json --section cpu,memory,disk
|
||||||
|
|
||||||
|
# A new server, seen before it is changed
|
||||||
|
sudo perl server-setup.pl --dry-run
|
||||||
|
|
||||||
|
# Cleanup, leaving journals and core dumps alone
|
||||||
|
sudo perl system-optimise.pl --skip-journal --skip-cores
|
||||||
|
|
||||||
|
# Deploy a model and then take it down again
|
||||||
|
sudo perl sglang-deploy.pl --model deepseek-ai/DeepSeek-V4-Flash-0731
|
||||||
|
sudo perl sglang-deploy.pl --uninstall
|
||||||
|
```
|
||||||
@@ -0,0 +1,105 @@
|
|||||||
|
# Deployment
|
||||||
|
|
||||||
|
The collection has two senses of deployment: how the scripts themselves are published,
|
||||||
|
and what they deploy when they run on a host. Both are below.
|
||||||
|
|
||||||
|
## Topology: publishing
|
||||||
|
|
||||||
|
The scripts are served from `https://petrbalvin.org/scripts/`, which is a directory on a
|
||||||
|
host reached over SSH. The Gitea instance at `sourcedock.dev` holds the repository and
|
||||||
|
runs the pipeline; there is no package, no tag and no artefact store, because a script
|
||||||
|
that is a single file is published by copying it.
|
||||||
|
|
||||||
|
```mermaid
|
||||||
|
flowchart LR
|
||||||
|
Dev[development branch] -->|merge| Main[main]
|
||||||
|
Main --> Runner[Gitea runner, alpine]
|
||||||
|
Runner -->|rsync over ssh| Host[petrbalvin.org]
|
||||||
|
Host -->|https| Client[client]
|
||||||
|
Runner -->|SHA256SUMS| Host
|
||||||
|
```
|
||||||
|
|
||||||
|
## Requirements
|
||||||
|
|
||||||
|
- The runner image is `alpine`, which carries `ssh`, `sshpass`, `rsync` and no Perl: the
|
||||||
|
pipeline installs Perl in its first step.
|
||||||
|
- Five repository secrets: `DEPLOY_HOST`, `DEPLOY_USER`, `DEPLOY_PATH`,
|
||||||
|
`DEPLOY_PASSWORD`, and `DEPLOY_KNOWN_HOSTS`.
|
||||||
|
- `DEPLOY_KNOWN_HOSTS` holds the host key, from
|
||||||
|
`ssh-keyscan -t ed25519 <host>`. The pipeline writes it into `~/.ssh/known_hosts` and
|
||||||
|
connects with `StrictHostKeyChecking=yes`; without the secret the deploy stops before
|
||||||
|
it starts, deliberately, because the alternative is trusting whatever answers on the
|
||||||
|
first connection.
|
||||||
|
|
||||||
|
## Build
|
||||||
|
|
||||||
|
There is nothing to build. The pipeline writes `SHA256SUMS`, one line per script, hashed
|
||||||
|
with `sha256sum` in sorted filename order so the file is stable between runs, and then
|
||||||
|
sends the scripts and that file.
|
||||||
|
|
||||||
|
## Run
|
||||||
|
|
||||||
|
The pipeline runs itself: merging into `main` publishes, and a manual dispatch republishes
|
||||||
|
the current tree.
|
||||||
|
|
||||||
|
```mermaid
|
||||||
|
sequenceDiagram
|
||||||
|
participant Dev
|
||||||
|
participant CI as Gitea runner
|
||||||
|
participant Host as petrbalvin.org
|
||||||
|
Dev->>CI: push to main
|
||||||
|
CI->>CI: write SHA256SUMS over every script
|
||||||
|
CI->>CI: pin the host key from DEPLOY_KNOWN_HOSTS
|
||||||
|
CI->>Host: rsync -avz --delete, the scripts and SHA256SUMS
|
||||||
|
Host-->>CI: exit status of rsync
|
||||||
|
CI->>CI: stop the run unless it was zero
|
||||||
|
```
|
||||||
|
|
||||||
|
`--delete` is deliberate: the host directory mirrors the repository, so a script removed
|
||||||
|
here disappears there. Nothing else lives in that directory.
|
||||||
|
|
||||||
|
## Upgrade and rollback
|
||||||
|
|
||||||
|
A publish is atomic per file as rsync writes it, and the previous copy is overwritten in
|
||||||
|
place. Rollback is a revert commit on `main`: the pipeline publishes the reverted tree on
|
||||||
|
the next push, and the host is back to the earlier scripts within the minute the run
|
||||||
|
takes. There is no rehearsal of that procedure on a staging host; it is the same
|
||||||
|
pipeline with the same single target.
|
||||||
|
|
||||||
|
## Monitoring
|
||||||
|
|
||||||
|
Nothing polls the host. Two things are worth watching by hand:
|
||||||
|
|
||||||
|
- The pipeline's own run history in Gitea, which fails loudly on a non-zero `rsync` or a
|
||||||
|
missing secret.
|
||||||
|
- `https://petrbalvin.org/scripts/SHA256SUMS`, which a client can compare against what it
|
||||||
|
downloaded. A file that is on the host but missing from `SHA256SUMS` means a publish was
|
||||||
|
interrupted.
|
||||||
|
|
||||||
|
## What the scripts deploy
|
||||||
|
|
||||||
|
Two of the six change a host's role, and a third prepares a desktop. Their output is the
|
||||||
|
deployment an operator cares about, so the pipeline that publishes them never runs them.
|
||||||
|
|
||||||
|
| Script | What it leaves behind | Where it is documented |
|
||||||
|
|---|---|---|
|
||||||
|
| `server-setup.pl` | Packages, firewalld with the SSH rule already allowed, SELinux enforcing, Podman, unattended updates | [docs/CLI.md](CLI.md) |
|
||||||
|
| `sglang-deploy.pl` | A systemd unit running the engine in a Podman container, nginx with TLS in front, an API key file, the firewall rule and the SELinux boolean | [docs/ARCHITECTURE.md](ARCHITECTURE.md) |
|
||||||
|
| `workstation-setup.pl` | A Fedora desktop with the toolchains and applications installed | [docs/CLI.md](CLI.md) |
|
||||||
|
|
||||||
|
The SGLang deployment is the only service in the collection, and the host needs no ROCm
|
||||||
|
installation for it: the engine runs from the project's ROCm image and reaches the GPU
|
||||||
|
through `/dev/kfd` and `/dev/dri`, which the amdgpu kernel driver provides. The image tag
|
||||||
|
follows the card and the host's ROCm, which is why the script resolves it rather than
|
||||||
|
carrying a constant.
|
||||||
|
|
||||||
|
## Production configuration
|
||||||
|
|
||||||
|
Nothing in this repository holds a secret. The values that differ per host come from
|
||||||
|
where the script reads them:
|
||||||
|
|
||||||
|
- The published copies are unversioned: whatever is on `main` is what is served.
|
||||||
|
- `sglang-deploy.pl` keeps the engine's API key in `/etc/sysconfig/sglang`, mode 0600,
|
||||||
|
written by the script and never committed. A Hugging Face token for a gated model goes
|
||||||
|
into that same file as `HF_TOKEN`, which the unit forwards to the container.
|
||||||
|
- The deploy secrets live in the Gitea repository settings, under Actions, Secrets.
|
||||||
@@ -0,0 +1,146 @@
|
|||||||
|
# Development
|
||||||
|
|
||||||
|
How to work on the scripts collection.
|
||||||
|
|
||||||
|
## Prerequisites
|
||||||
|
|
||||||
|
- Perl 5.38 or newer, which is what the oldest supported system ships. Measured on the
|
||||||
|
three test platforms: Fedora 44 carries 5.42.3, CentOS Stream 10 carries 5.40.2, and
|
||||||
|
openEuler 24.03 LTS carries 5.38.0.
|
||||||
|
- Podman, for the container rigs that verify a script against a real system.
|
||||||
|
- Nothing else. There is no build step, no dependency to install and no module to fetch:
|
||||||
|
the scripts use the interpreter's builtins, and the checks use nothing beyond them
|
||||||
|
either.
|
||||||
|
|
||||||
|
## Setup
|
||||||
|
|
||||||
|
```sh
|
||||||
|
git clone https://sourcedock.dev/petrbalvin/scripts.git
|
||||||
|
cd scripts
|
||||||
|
perl -c network-diag.pl
|
||||||
|
```
|
||||||
|
|
||||||
|
## Commands
|
||||||
|
|
||||||
|
There is no recipe file: the gates are the commands below, and the test pipeline runs
|
||||||
|
the same set.
|
||||||
|
|
||||||
|
| Command | What it does |
|
||||||
|
|---|---|
|
||||||
|
| `perl -c <script>` | Compiles one script. All six in a loop is what the pipeline's first gate does |
|
||||||
|
| `perl tests/<script>.pl` | One script's checks, each printing `ok` or `FAIL` and exiting non-zero on a failure |
|
||||||
|
| `perl tests/container/rig.pl` | The container rig, which must be run through Podman as root: see below |
|
||||||
|
|
||||||
|
The whole local gate, one line per script:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
for f in *.pl; do perl -c "$f" || exit 1; done
|
||||||
|
for t in tests/*.pl; do perl "$t" || exit 1; done
|
||||||
|
```
|
||||||
|
|
||||||
|
Two more gates have no command of their own because the pipeline carries them: every
|
||||||
|
script opens with the shebang `#!/usr/bin/env perl` and the two-line licence header,
|
||||||
|
and no file in the repository uses a dash as punctuation. Both are checked in
|
||||||
|
`.gitea/workflows/test.yml`.
|
||||||
|
|
||||||
|
## The checks under tests/
|
||||||
|
|
||||||
|
One file per script, named after it, run as `perl tests/<script>.pl`. They cover the
|
||||||
|
pure functions, which is where the arithmetic and the parsing live: RPM's version
|
||||||
|
comparison (checked against `rpm`'s own implementation, which is the definition of the
|
||||||
|
ordering), the two JSON decoders and the encoder, IPv4 and IPv6 parsing with the
|
||||||
|
`sockaddr` packing and the address classification, the ping transcript parser, the
|
||||||
|
grading, the dnf-automatic renderer, the checksum reader, the writers, and the argument
|
||||||
|
parsing of every script.
|
||||||
|
|
||||||
|
They need no root, no network and no Podman, except where a case is skipped for that
|
||||||
|
reason and says so: `atomic_write` settles the owner of the file it writes, so it can
|
||||||
|
only be exercised as root.
|
||||||
|
|
||||||
|
## The container rig
|
||||||
|
|
||||||
|
`tests/container/rig.pl` runs the real `sglang-deploy.pl` as root inside a container
|
||||||
|
against a stub `PATH`: every command the script drives (`dnf`, `rpm`, `podman`,
|
||||||
|
`systemctl`, `curl`, `openssl`, `nginx`, `firewall-cmd`, `getsebool`, `lspci`) is a
|
||||||
|
stub that answers from a fixture, so a run is deterministic and needs no network and no
|
||||||
|
GPU. It covers the deploy end to end: the resolved image tag, the unit file, the nginx
|
||||||
|
configuration, the TLS certificate and its modes, the API key file, the SELinux
|
||||||
|
boolean, the firewall rule, the idempotent second run, the dry run, the uninstall, the
|
||||||
|
Radeon and MI300 paths, the offline and unpublished-tag failures, the argument
|
||||||
|
validation and the non-root refusal.
|
||||||
|
|
||||||
|
Prepare the platform image once, since the base images carry no Perl:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
podman run --name sglang-prep registry.fedoraproject.org/fedora:44 dnf install -y perl
|
||||||
|
podman commit sglang-prep localhost/sglang-rig:fedora
|
||||||
|
podman rm sglang-prep
|
||||||
|
```
|
||||||
|
|
||||||
|
Then run the scenarios. The repository is mounted read-only at its own path and the
|
||||||
|
work directory is a scratch directory outside it:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
podman run --rm --privileged \
|
||||||
|
-v "$PWD:$PWD:ro,z" \
|
||||||
|
-v /tmp/sglang-rig:/tmp/sglang-rig:Z \
|
||||||
|
localhost/sglang-rig:fedora perl "$PWD/tests/container/rig.pl"
|
||||||
|
```
|
||||||
|
|
||||||
|
The device nodes the script requires are faked by the rig itself, which is why the
|
||||||
|
container needs `--privileged`. The one scenario that checks the *missing* driver needs
|
||||||
|
a run without it:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
podman run --rm \
|
||||||
|
-v "$PWD:$PWD:ro,z" \
|
||||||
|
-v /tmp/sglang-rig:/tmp/sglang-rig:Z \
|
||||||
|
localhost/sglang-rig:fedora perl "$PWD/tests/container/rig.pl" no_driver
|
||||||
|
```
|
||||||
|
|
||||||
|
The same rig was run on all three platforms, which is how the script's behaviour
|
||||||
|
against their package managers and their `os-release` was confirmed; only the image tag
|
||||||
|
in the commands changes:
|
||||||
|
|
||||||
|
| Platform | Image | Perl |
|
||||||
|
|---|---|---|
|
||||||
|
| Fedora 44 | `registry.fedoraproject.org/fedora:44` | 5.42.3 |
|
||||||
|
| CentOS Stream 10 | `quay.io/centos/centos:stream10` | 5.40.2 |
|
||||||
|
| openEuler 24.03 LTS | `docker.io/openeuler/openeuler:24.03-lts` | 5.38.0 |
|
||||||
|
|
||||||
|
A run leaves its log in `/tmp/sglang-rig/log/`, including `run.out`, the script's own
|
||||||
|
output, and `stubs.log`, every command it issued with its arguments. That log is the
|
||||||
|
quickest way to see what a run actually did.
|
||||||
|
|
||||||
|
## Running one script for real
|
||||||
|
|
||||||
|
The diagnostic scripts need no root and can simply be run:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
perl network-diag.pl
|
||||||
|
perl system-diag.pl --json
|
||||||
|
```
|
||||||
|
|
||||||
|
The four that change a system need root and, except for
|
||||||
|
`workstation-setup.pl`, run in a disposable container the same way the rig does. Start
|
||||||
|
from the platform image, and read the summary before anything else: every one of them
|
||||||
|
supports `--dry-run`, which changes nothing and prints what it would do.
|
||||||
|
|
||||||
|
## Continuous integration
|
||||||
|
|
||||||
|
Workflows live in `.gitea/workflows/` and run on the project's own runners:
|
||||||
|
|
||||||
|
| Workflow | Trigger | Steps |
|
||||||
|
|---|---|---|
|
||||||
|
| Test | push or pull request to `development` | install Perl, then the syntax gate, the licence-header gate, the punctuation gate, and the six check files |
|
||||||
|
| Deploy | push to `main`, or dispatched by hand | write `SHA256SUMS`, pin the host key from `DEPLOY_KNOWN_HOSTS`, publish over rsync |
|
||||||
|
|
||||||
|
The container rig is deliberately not in the pipeline: it needs `--privileged`, and the
|
||||||
|
runner is a small box shared with the forge. A change that touches a system is expected
|
||||||
|
to be verified with the rig locally, and the pull request says which platform was used.
|
||||||
|
|
||||||
|
## Releases
|
||||||
|
|
||||||
|
There are none. Each script carries its own version string, and the deploy pipeline
|
||||||
|
publishes the scripts on every push to `main`, so a merge is a release and the commit
|
||||||
|
history is the record of what changed.
|
||||||
+1584
File diff suppressed because it is too large
Load Diff
+2350
File diff suppressed because it is too large
Load Diff
+1861
File diff suppressed because it is too large
Load Diff
+2604
File diff suppressed because it is too large
Load Diff
+2325
File diff suppressed because it is too large
Load Diff
+1727
File diff suppressed because it is too large
Load Diff
@@ -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);
|
||||||
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user