526 lines
18 KiB
Perl
526 lines
18 KiB
Perl
#!/usr/bin/perl
|
|
#
|
|
# Copyright Zaher Salman 2023-.
|
|
# zaher.salman@psi.ch
|
|
# SPDX-License-Identifier: GPL-3.0-or-later
|
|
#
|
|
# singleTrimSP.cgi
|
|
#
|
|
# Web backend for TRIMSP-NL: accepts a run directory + file name with the
|
|
# submitted file content, runs the transport engine, and on request produces a
|
|
# downloadable results archive.
|
|
#
|
|
# Actions:
|
|
# (none) POST fn + rngType + lineN... write the file, then run/archive
|
|
# read GET fn stream a run-directory file
|
|
# download GET run stream the results archive (.tgz)
|
|
# health GET deployment self-check (JSON)
|
|
#
|
|
# The browser contract is deliberately unchanged from before the hardening:
|
|
# JSON responses keep ok/phase/message/exitCode/archiveUrl/log;
|
|
# read/download stream text/gzip with real HTTP status codes.
|
|
#
|
|
# Environment overrides (all optional; nothing here requires Apache config):
|
|
# TRIMSP_BIN - path to the trimspNL engine (the deploy script rewrites
|
|
# the $trimsp_bin literal below; env is a fallback)
|
|
# TRIMSP_TMPROOT - run root (default /tmp). The browser builds paths as
|
|
# <root>/<run>/<file>, so changing this requires the
|
|
# matching client change; the default is safe.
|
|
# TRIMSP_CMD_TIMEOUT - per-command watchdog seconds (default 300). Must stay
|
|
# above the engine's own internal bounds.
|
|
# TRIMSP_JOB_MAXAGE - stale run/archive lifetime seconds (default 86400).
|
|
|
|
use strict;
|
|
use warnings;
|
|
use CGI;
|
|
use File::Path qw(make_path remove_tree);
|
|
use File::Temp qw(tempfile);
|
|
use Fcntl qw(:DEFAULT :flock);
|
|
use JSON::PP qw(encode_json);
|
|
|
|
# The web installer rewrites this path to the selected installed binary.
|
|
my $trimsp_bin = "/usr/local/bin/trimspNL";
|
|
my $workroot = "/tmp";
|
|
|
|
$trimsp_bin = $ENV{TRIMSP_BIN} if defined($ENV{TRIMSP_BIN}) && $ENV{TRIMSP_BIN} ne "";
|
|
$workroot = $ENV{TRIMSP_TMPROOT} if defined($ENV{TRIMSP_TMPROOT}) && $ENV{TRIMSP_TMPROOT} ne "";
|
|
|
|
# Per-command watchdog. Every external command (trimspNL, tar) is bounded by an
|
|
# alarm() watchdog in run_bounded_command and killed as a process group, so a
|
|
# hung engine or tar cannot strand an Apache worker indefinitely.
|
|
my $CMD_TIMEOUT = (defined($ENV{TRIMSP_CMD_TIMEOUT}) && $ENV{TRIMSP_CMD_TIMEOUT} =~ /^\d+$/)
|
|
? int($ENV{TRIMSP_CMD_TIMEOUT}) : 300;
|
|
|
|
# Job/archive lifetime in seconds. prune_stale_jobs() removes trimsp run
|
|
# directories and orphaned archives older than this, bounding disk usage from
|
|
# long-running or abandoned browser sessions.
|
|
my $JOB_MAXAGE = (defined($ENV{TRIMSP_JOB_MAXAGE}) && $ENV{TRIMSP_JOB_MAXAGE} =~ /^\d+$/)
|
|
? int($ENV{TRIMSP_JOB_MAXAGE}) : 86400;
|
|
|
|
# Request-body caps. The browser posts one cfg, one .inp per scan point, and one
|
|
# sequence file; these limits stay far above real decks while stopping a crafted
|
|
# link from pushing unbounded content into the run directory.
|
|
my $MAX_REQUEST_LINES = 20000;
|
|
my $MAX_REQUEST_BYTES = 4 * 1024 * 1024;
|
|
|
|
# Run name: alphanumerics, underscore, hyphen only (no dot, so ".", ".." can
|
|
# never be a path component). A run-name class that admitted dots is exactly
|
|
# the traversal hole muSRFlow carries; keep it dot-free. \z (not $) additionally
|
|
# rejects a trailing newline from a %0A tail. The file component stays nested in
|
|
# the same anchored pattern below, so no separate file-name regex is needed.
|
|
my $run_name_re = qr{^[A-Za-z0-9_-]+\z};
|
|
|
|
# Derive the path allowlist from the configured root so a TRIMSP_TMPROOT
|
|
# override stays consistent across every action.
|
|
my $work_path_re = qr{^\Q$workroot\E/([A-Za-z0-9_-]+)/([A-Za-z0-9_.-]+)\z};
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Helpers
|
|
# ----------------------------------------------------------------------------
|
|
|
|
# Emit an error as a real HTTP status code with a JSON body, then exit. The
|
|
# payload carries the original ok/phase/message fields only, so error responses
|
|
# keep exactly the same shape the browser already understands.
|
|
sub json_error {
|
|
my ($status, $payload) = @_;
|
|
print "Status: $status\r\n";
|
|
print "Content-Type: application/json; charset=UTF-8\r\n";
|
|
print "Cache-Control: no-store\r\n\r\n";
|
|
print encode_json($payload);
|
|
exit 0;
|
|
}
|
|
|
|
# Shell quoting for browser-derived command components. After the path checks
|
|
# the tokens still go through shell_quote(); only server-side literals are ever
|
|
# interpolated unquoted.
|
|
sub shell_quote {
|
|
my ($s) = @_;
|
|
$s =~ s/'/'\\''/g;
|
|
return "'" . $s . "'";
|
|
}
|
|
|
|
# Run an arbitrary shell command with an alarm() watchdog, isolating the child
|
|
# in its own process group so a timeout can kill the whole pipeline (including
|
|
# grandchildren) without touching this CGI process. Returns system()'s waited
|
|
# status encoding, or -1 (could not start) / -2 (watchdog fired).
|
|
sub run_bounded_command {
|
|
my ($command) = @_;
|
|
my $pid = fork();
|
|
return -1 if !defined($pid);
|
|
if ($pid == 0) {
|
|
setpgrp(0, 0);
|
|
umask(022);
|
|
open(STDIN, "<", "/dev/null") or _exit(127);
|
|
exec { "/bin/sh" } "/bin/sh", "-c", $command;
|
|
_exit(127);
|
|
}
|
|
|
|
my $timed_out = 0;
|
|
local $SIG{ALRM} = sub {
|
|
$timed_out = 1;
|
|
kill "KILL", -$pid;
|
|
};
|
|
my $status = -1;
|
|
eval {
|
|
alarm($CMD_TIMEOUT);
|
|
waitpid($pid, 0);
|
|
alarm(0);
|
|
$status = $?;
|
|
};
|
|
my $wait_error = $@;
|
|
alarm(0);
|
|
if ($timed_out) {
|
|
# waitpid may be interrupted by SIGALRM or return after the killed child
|
|
# is reaped. A second call is harmless in the latter case and avoids a
|
|
# zombie in the former.
|
|
waitpid($pid, 0);
|
|
return -2;
|
|
}
|
|
if ($wait_error) {
|
|
kill "KILL", -$pid;
|
|
waitpid($pid, 0);
|
|
return -1;
|
|
}
|
|
return $status;
|
|
}
|
|
|
|
# Convert a run_bounded_command result into (exit_code, human description)
|
|
# matching the vocabulary the browser shows in diagnostics.
|
|
sub describe_result {
|
|
my ($result) = @_;
|
|
if ($result == -2) {
|
|
return (124, "timed out after ${CMD_TIMEOUT}s");
|
|
} elsif ($result == -1) {
|
|
return (127, "failed to start: $!");
|
|
} elsif ($result & 127) {
|
|
return (128 + ($result & 127), "terminated by signal " . ($result & 127));
|
|
}
|
|
return ($result >> 8, "exit code " . ($result >> 8));
|
|
}
|
|
|
|
# Accept or create the run directory. Refuses symlinks and non-directories so a
|
|
# pre-created /tmp/<run> link or planted file cannot redirect our writes, and
|
|
# uses mode 0700 so results are not world-readable in the shared temp root.
|
|
sub ensure_safe_work_dir {
|
|
my ($work_path) = @_;
|
|
if (-l $work_path || (-e $work_path && !-d $work_path)) {
|
|
return (0, "job directory is not a plain directory");
|
|
}
|
|
if (!-d $work_path) {
|
|
if (!-d $workroot) {
|
|
return (0, "run root does not exist");
|
|
}
|
|
my $ok = eval {
|
|
make_path($work_path, { mode => 0700, error => \my $err });
|
|
!@{$err};
|
|
};
|
|
if (!$ok) {
|
|
return (0, "could not create job directory");
|
|
}
|
|
}
|
|
return (1, "");
|
|
}
|
|
|
|
# Occupy the per-run archive lock. The archive step mutates the whole run
|
|
# directory (tar + remove_tree), so it is serialized; the per-point engine runs
|
|
# are intentionally concurrent and are not locked. The kernel releases flock
|
|
# when the CGI exits, so a dying worker cannot strand the lock.
|
|
sub lock_archive {
|
|
my ($work_path) = @_;
|
|
my $lock_path = "$work_path/.trimsp-lock";
|
|
my $lfh;
|
|
if (!sysopen($lfh, $lock_path, O_RDWR | O_CREAT, 0600)) {
|
|
return undef;
|
|
}
|
|
if (!flock($lfh, LOCK_EX | LOCK_NB)) {
|
|
close($lfh);
|
|
return undef;
|
|
}
|
|
return $lfh;
|
|
}
|
|
|
|
# Age out abandoned trimsp jobs. Mirrors muSRFlow's pruner but stays safe in
|
|
# the shared /tmp root: only directories that match the run-name rule AND
|
|
# contain a TrimSP.cfg marker are candidates, plus orphaned <run>.tgz archives
|
|
# whose run directory is already gone, plus leaked per-request log files.
|
|
# Symlinks are skipped and remove_tree runs in safe mode, so a crafted entry is
|
|
# never followed or deleted.
|
|
sub prune_stale_jobs {
|
|
return 0 if !-d $workroot;
|
|
my $now = time();
|
|
my $removed = 0;
|
|
|
|
opendir(my $dh, $workroot) or return 0;
|
|
while (my $entry = readdir($dh)) {
|
|
next if $entry eq "." || $entry eq "..";
|
|
next if $entry !~ /^[A-Za-z0-9_-]{5,}$/;
|
|
my $candidate = "$workroot/$entry";
|
|
next if -l $candidate || !-d $candidate;
|
|
# Only ever touch directories this backend creates.
|
|
next if !-f "$candidate/TrimSP.cfg";
|
|
my @stats = stat($candidate);
|
|
next if @stats < 9;
|
|
next if $stats[9] > $now - $JOB_MAXAGE;
|
|
# Never delete a directory that is currently being archived.
|
|
my $lock = "$candidate/.trimsp-lock";
|
|
if (-e $lock) {
|
|
sysopen(my $lfh, $lock, O_RDWR | O_CREAT, 0600) or next;
|
|
if (!flock($lfh, LOCK_EX | LOCK_NB)) { close($lfh); next; }
|
|
close($lfh);
|
|
}
|
|
remove_tree($candidate, { safe => 1, error => \my $err });
|
|
$removed++ if !@{$err};
|
|
}
|
|
closedir($dh);
|
|
|
|
# Orphaned archives: /tmp/<run>.tgz whose run directory is already gone.
|
|
opendir($dh, $workroot) or return $removed;
|
|
while (my $entry = readdir($dh)) {
|
|
next if $entry !~ /^([A-Za-z0-9_-]{5,})\.tgz\z/;
|
|
next if -d "$workroot/$1";
|
|
my $path = "$workroot/$entry";
|
|
next if -l $path || !-f $path;
|
|
my @stats = stat($path);
|
|
next if @stats < 9 || $stats[9] > $now - $JOB_MAXAGE;
|
|
unlink($path);
|
|
$removed++;
|
|
}
|
|
closedir($dh);
|
|
|
|
# Leaked per-request logs from requests that died before unlink().
|
|
opendir($dh, $workroot) or return $removed;
|
|
while (my $entry = readdir($dh)) {
|
|
next if $entry !~ /^trimsp-([A-Za-z0-9_-]{5,})-[A-Za-z0-9_-]{4,}\z/;
|
|
my $path = "$workroot/$entry";
|
|
next if -l $path || !-f $path;
|
|
my @stats = stat($path);
|
|
next if @stats < 9 || $stats[9] > $now - $JOB_MAXAGE;
|
|
unlink($path);
|
|
$removed++;
|
|
}
|
|
closedir($dh);
|
|
|
|
return $removed;
|
|
}
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# Request dispatch
|
|
# ----------------------------------------------------------------------------
|
|
|
|
my $in = CGI->new;
|
|
my $action = $in->param("action") // "run";
|
|
|
|
# Opportunistically age out stale jobs before serving or mutating anything.
|
|
prune_stale_jobs();
|
|
|
|
if ($action eq "read") {
|
|
my $read_filename = $in->param("fn") // "";
|
|
if ($read_filename !~ $work_path_re || !-f $read_filename || -l $read_filename) {
|
|
print "Status: 404 Not Found\r\n";
|
|
print "Content-Type: text/plain; charset=UTF-8\r\n\r\n";
|
|
print "Requested simulation output was not found.\n";
|
|
exit 0;
|
|
}
|
|
|
|
open(my $input_file, "<", $read_filename) or do {
|
|
print "Status: 500 Internal Server Error\r\n";
|
|
print "Content-Type: text/plain; charset=UTF-8\r\n\r\n";
|
|
print "Requested simulation output could not be read.\n";
|
|
exit 0;
|
|
};
|
|
print "Content-Type: text/plain; charset=UTF-8\r\n\r\n";
|
|
while (read($input_file, my $buffer, 65536)) {
|
|
print $buffer;
|
|
}
|
|
close($input_file);
|
|
exit 0;
|
|
}
|
|
|
|
if ($action eq "download") {
|
|
my $download_run = $in->param("run") // "";
|
|
my $archive_path = "$workroot/$download_run.tgz";
|
|
if ($download_run !~ $run_name_re || !-f $archive_path || -l $archive_path) {
|
|
print "Status: 404 Not Found\r\n";
|
|
print "Content-Type: text/plain; charset=UTF-8\r\n\r\n";
|
|
print "Requested results archive was not found.\n";
|
|
exit 0;
|
|
}
|
|
|
|
open(my $archive_file, "<", $archive_path) or do {
|
|
print "Status: 500 Internal Server Error\r\n";
|
|
print "Content-Type: text/plain; charset=UTF-8\r\n\r\n";
|
|
print "Requested results archive could not be read.\n";
|
|
exit 0;
|
|
};
|
|
binmode($archive_file);
|
|
binmode(STDOUT);
|
|
print "Content-Type: application/gzip\r\n";
|
|
print "Content-Disposition: attachment; filename=\"$download_run.tgz\"\r\n";
|
|
print "Content-Length: " . (-s $archive_path) . "\r\n\r\n";
|
|
while (read($archive_file, my $buffer, 65536)) {
|
|
print $buffer;
|
|
}
|
|
close($archive_file);
|
|
exit 0;
|
|
}
|
|
|
|
if ($action eq "health") {
|
|
my %probe;
|
|
$probe{engine} = {
|
|
exists => (-e $trimsp_bin) ? JSON::PP::true : JSON::PP::false,
|
|
executable => (-x $trimsp_bin) ? JSON::PP::true : JSON::PP::false,
|
|
size => (-f $trimsp_bin && !-l $trimsp_bin) ? (-s $trimsp_bin || 0) : 0,
|
|
};
|
|
$probe{runRoot} = {
|
|
exists => (-d $workroot) ? JSON::PP::true : JSON::PP::false,
|
|
writable => (-w $workroot) ? JSON::PP::true : JSON::PP::false,
|
|
};
|
|
$probe{settings} = {
|
|
commandTimeoutSeconds => $CMD_TIMEOUT,
|
|
jobMaxAgeSeconds => $JOB_MAXAGE,
|
|
maxRequestBytes => $MAX_REQUEST_BYTES,
|
|
maxRequestLines => $MAX_REQUEST_LINES,
|
|
};
|
|
print "Content-Type: application/json\r\n";
|
|
print "Cache-Control: no-store\r\n\r\n";
|
|
print encode_json({
|
|
ok => JSON::PP::true,
|
|
action => "health",
|
|
probe => \%probe,
|
|
});
|
|
exit 0;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Write + run path (default action). The browser posts fn + rngType + lineN...
|
|
# ---------------------------------------------------------------------------
|
|
|
|
my $requested_filename = $in->param("fn") // "";
|
|
my $rng_type = $in->param("rngType") // "pcg32";
|
|
|
|
# Accept only the private run path produced by TrimSPweb.js. Restricting both
|
|
# path components prevents CGI parameters from selecting arbitrary files.
|
|
if ($requested_filename !~ $work_path_re) {
|
|
json_error(400, {
|
|
ok => JSON::PP::false,
|
|
phase => "request",
|
|
message => "Invalid simulation filename",
|
|
});
|
|
}
|
|
|
|
my ($run_name, $file_name) = ($1, $2);
|
|
$rng_type = "pcg32" unless $rng_type =~ /^(?:ranlux|pcg32|xoshiro|xoshiro256)$/;
|
|
|
|
my $work_path = "$workroot/$run_name";
|
|
my $filename = "$work_path/$file_name";
|
|
my $run_base = $file_name;
|
|
$run_base =~ s/\.inp$//;
|
|
|
|
# Reconstruct submitted file content in numeric line order. CGI parameter
|
|
# iteration order is not guaranteed for line10, line11, and later fields.
|
|
my @line_parameters = sort {
|
|
($a =~ /line(\d+)/)[0] <=> ($b =~ /line(\d+)/)[0]
|
|
} grep { /^line\d+$/ } $in->param;
|
|
if (@line_parameters > $MAX_REQUEST_LINES) {
|
|
json_error(413, {
|
|
ok => JSON::PP::false,
|
|
phase => "request",
|
|
message => "Too many submitted lines",
|
|
});
|
|
}
|
|
my $content = join("\n", map { scalar($in->param($_) // "") } @line_parameters) . "\n";
|
|
if (length($content) > $MAX_REQUEST_BYTES) {
|
|
json_error(413, {
|
|
ok => JSON::PP::false,
|
|
phase => "request",
|
|
message => "Submitted file content is too large",
|
|
});
|
|
}
|
|
|
|
my ($dir_ok, $dir_message) = ensure_safe_work_dir($work_path);
|
|
if (!$dir_ok) {
|
|
json_error(500, {
|
|
ok => JSON::PP::false,
|
|
phase => "request",
|
|
message => $dir_message,
|
|
});
|
|
}
|
|
open(my $output_file, ">", $filename) or do {
|
|
json_error(500, {
|
|
ok => JSON::PP::false,
|
|
phase => "write",
|
|
message => "Could not write the submitted simulation file",
|
|
});
|
|
};
|
|
print {$output_file} $content;
|
|
close($output_file);
|
|
|
|
my $phase = "save";
|
|
my $message = "Saved $file_name";
|
|
my $exit_code;
|
|
my $archive_url;
|
|
my $log_content = "";
|
|
my $request_logfile;
|
|
my $ok = JSON::PP::true;
|
|
|
|
# Append diagnostics to the private request log before and after a command so
|
|
# the JSON log field explains timeouts/signals instead of a bare exit code.
|
|
sub append_log {
|
|
my ($logfile, $text) = @_;
|
|
return unless $logfile;
|
|
return unless open(my $lfh, ">>", $logfile);
|
|
print {$lfh} $text;
|
|
close($lfh);
|
|
}
|
|
|
|
if ($filename =~ /_Seq_Results\.dat$/) {
|
|
$phase = "archive";
|
|
unlink("$work_path/edist");
|
|
|
|
# Only simulation files live in the run directory. Diagnostic output is
|
|
# captured separately and is therefore excluded from the archive.
|
|
my $archive_path = "$workroot/$run_name.tgz";
|
|
my ($log_handle, $logfile) = tempfile("trimsp-$run_name-XXXXXX", DIR => $workroot, UNLINK => 0);
|
|
close($log_handle);
|
|
$request_logfile = $logfile;
|
|
|
|
my $lock_fh = lock_archive($work_path);
|
|
if (!$lock_fh) {
|
|
$ok = JSON::PP::false;
|
|
$message = "Another archive operation is active in this run";
|
|
} else {
|
|
# Replace a previous archive defensively, refusing a symlink target.
|
|
if (-e $archive_path || -l $archive_path) {
|
|
if (-l $archive_path || !-f $archive_path || !unlink($archive_path)) {
|
|
$ok = JSON::PP::false;
|
|
$message = "Could not replace the previous results archive";
|
|
}
|
|
}
|
|
if ($ok) {
|
|
my $command = "tar -czf " . shell_quote($archive_path)
|
|
. " -C " . shell_quote($work_path)
|
|
. " --exclude=./.trimsp-lock . "
|
|
. ">> " . shell_quote($logfile) . " 2>&1";
|
|
append_log($logfile, "\n[archive] \$ $command\n");
|
|
my $result = run_bounded_command($command);
|
|
($exit_code, my $completion) = describe_result($result);
|
|
append_log($logfile, "[${completion}]\n");
|
|
if ($exit_code == 0 && -s $archive_path) {
|
|
$archive_url = "/cgi-bin/singleTrimSP.cgi?action=download&run=$run_name";
|
|
$message = "Created results archive";
|
|
remove_tree($work_path);
|
|
} else {
|
|
# A run that produced correct physics must not be reported as a
|
|
# failure just because archiving failed.
|
|
$ok = JSON::PP::false;
|
|
$message = "Could not create results archive";
|
|
unlink($archive_path) if -f $archive_path && !-l $archive_path;
|
|
}
|
|
}
|
|
close($lock_fh);
|
|
}
|
|
} elsif ($filename !~ /TrimSP\.cfg$/) {
|
|
$phase = "simulation";
|
|
my ($log_handle, $logfile) = tempfile("trimsp-$run_name-XXXXXX", DIR => $workroot, UNLINK => 0);
|
|
close($log_handle);
|
|
$request_logfile = $logfile;
|
|
|
|
# All user-derived command components were restricted above. Each request
|
|
# receives a private log file so concurrent users never share output.
|
|
my $command = "cd " . shell_quote($work_path) . " && "
|
|
. shell_quote($trimsp_bin) . " "
|
|
. shell_quote($run_base) . " "
|
|
. shell_quote($rng_type) . " >> " . shell_quote($logfile) . " 2>&1";
|
|
append_log($logfile, "\n[simulation] \$ $command\n");
|
|
my $result = run_bounded_command($command);
|
|
($exit_code, my $completion) = describe_result($result);
|
|
append_log($logfile, "[${completion}]\n");
|
|
$ok = JSON::PP::false if $exit_code != 0;
|
|
$message = $exit_code == 0
|
|
? "TRIM.SP-NL completed $run_base"
|
|
: "TRIM.SP-NL failed while running $run_base ($completion)";
|
|
}
|
|
|
|
# Return at most the latest 64 KiB to the browser and immediately remove the
|
|
# temporary server-side copy. Diagnostic logs never enter the results archive.
|
|
if ($request_logfile && -f $request_logfile && open(my $log_handle, "<", $request_logfile)) {
|
|
my $log_size = -s $log_handle;
|
|
seek($log_handle, $log_size - 65536, 0) if $log_size > 65536;
|
|
local $/;
|
|
$log_content = <$log_handle> // "";
|
|
close($log_handle);
|
|
unlink($request_logfile);
|
|
}
|
|
|
|
print "Content-Type: application/json; charset=UTF-8\r\n";
|
|
print "Cache-Control: no-store\r\n\r\n";
|
|
print encode_json({
|
|
ok => $ok,
|
|
phase => $phase,
|
|
message => $message,
|
|
exitCode => $exit_code,
|
|
archiveUrl => $archive_url,
|
|
log => $log_content,
|
|
});
|
|
|
|
exit 0; |