#!/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;