#!/usr/bin/env perl

use strict;
use warnings;
use Test::Most;
use File::Spec;
use File::Temp qw(tempdir);
use File::Path qw(make_path);
use File::Basename qw(dirname);
use Cwd qw(abs_path);
use HTML::Entities qw(encode_entities);
use Readonly;

# Penetration tests for bin/test-generator-index.
#
# The script cannot be require'd because it has top-level executable code.
# Security-sensitive logic is tested via inline copies (matching the
# pattern established in t/test-generator-index.t) and, for integration
# tests, by running the script as a subprocess with crafted inputs.

# ==================================================================
# Constants — attack payloads
# ==================================================================

Readonly my $XSS_SCRIPT_TAG   => '<script>alert("XSS")</script>';
Readonly my $XSS_IMG_ONERROR  => '<img src=x onerror=alert(1)>';
Readonly my $XSS_ENTITY_CHAIN => '&lt;script&gt;alert(1)&lt;/script&gt;';
Readonly my $NULL_BYTE        => "\x00";
Readonly my $CRLF             => "\r\n";
Readonly my $SHELL_BACKTICK   => '`id`';
Readonly my $SHELL_DOLLAR_SUB => '$(id)';

# ==================================================================
# Inline helpers — mirrors of private functions in the script.
# These must be kept in sync with the source; the comments note
# which line in the script each copy derives from.
# ==================================================================

# Mirrors _resolve_report_path() from t/test-generator-index.t
# (which itself mirrors the guard in _mutant_file_report around line 5355).
sub _resolve_report_path {
	my ($dir, $file) = @_;

	die "Refusing to report on suspicious file path: $file\n"
		if $file =~ /\0/
		|| grep { $_ eq File::Spec->updir } File::Spec->splitdir($file);

	my $relative_path = File::Spec->catfile($dir, $file . '.html');
	my $out_dir = dirname($relative_path);

	make_path($out_dir) unless -d $out_dir;

	my $resolved_dir = abs_path($dir) // $dir;
	my $resolved_out = abs_path($out_dir) // $out_dir;
	die "Refusing to write report outside $dir: $relative_path\n"
		unless index($resolved_out, $resolved_dir) == 0;

	return $relative_path;
}

# Mirrors generate_reproduction_script() (~line 2274) with identical logic.
sub generate_reproduction_script {
	my ($dist, $version, $report, $installed_mods, $outdir) = @_;

	my $guid     = $report->{guid}     or return;
	$guid =~ s/[\r\n\x00-\x1f]//g;
	return unless length $guid;
	my $perl     = $report->{perl}     // 'unknown';
	$perl =~ s/[\r\n\x00-\x1f]//g;
	my $os       = $report->{osname}   // 'unknown';
	$os =~ s/[\r\n\x00-\x1f]//g;
	my $reporter = $report->{reporter} // '';
	$reporter =~ s/"//g;
	$reporter =~ s/<[^>]+>//g;
	$reporter =~ s/[\r\n\x00-\x1f]//g;
	$reporter =~ s/\s+$//g;

	my $repro_dir  = File::Spec->catdir($outdir, 'reproduce');
	make_path($repro_dir) unless -d $repro_dir;

	my $script_name = "reproduce-$guid.sh";
	my $script_path = File::Spec->catfile($repro_dir, $script_name);

	open my $fh, '>', $script_path or return;

	print $fh "#!/bin/sh\n";
	print $fh "# Reproduction script for CPAN Testers report $guid\n";
	print $fh "# Distribution: $dist-$version\n";
	print $fh "# Perl: $perl  OS: $os\n";
	print $fh "# Reporter: $reporter\n";
	print $fh "# Report: https://www.cpantesters.org/cpan/report/$guid\n";
	print $fh "# Generated by test-generator-index (App::Test::Generator)\n";
	print $fh "set -e\n\n";
	print $fh "# Use Perl $perl (perlbrew / plenv recommended)\n";
	print $fh "# perlbrew install perl-$perl && perlbrew use perl-$perl\n\n";

	if(%$installed_mods) {
		print $fh "# Install exact dependency versions from the failing report\n";
		my @mod_lines = map { "\t'$_\@$installed_mods->{$_}'" }
		                sort keys %$installed_mods;
		print $fh "cpanm --notest \\\n", join(" \\\n", @mod_lines), "\n\n";
	}

	print $fh "# Install and test the failing distribution\n";
	print $fh "cpanm --look $dist\@$version\n";
	print $fh "# or from a local checkout: perl Makefile.PL && make && make test\n";

	close $fh;
	chmod 0755, $script_path;

	return $script_name;
}

# Mirrors js_escape() (~line 2187).
sub js_escape {
	my $str = $_[0];
	$str =~ s/\\/\\\\/g;
	$str =~ s/"/\\"/g;
	$str =~ s/\n/\\n/g;
	return $str;
}

# Mirrors extract_installed_modules() (~line 2321 area, as in t/test-generator-index.t).
sub extract_installed_modules {
	my ($html) = @_;
	my %mods;

	return \%mods unless $html;

	if($html =~ /Installed modules:(.*?)(?:\n\n|\z)/s) {
		my $block = $1;
		while($block =~ /^\s*([A-Z]\w*(?:::\w+)*)\s+v?([\d._]+)/mg) {
			my ($module, $version) = ($1, $2);
			next if $module =~ /^(Perl|OS|Reporter|Tester)$/;
			$mods{$module} = $version;
		}
	}

	return \%mods;
}

# Renders mutant description HTML the same way _mutant_file_report does
# (~line 5757-5760 in the script).  Uses encode_entities() on every
# field that originates from mutation.json, mirroring the fix applied
# after pen testing confirmed the XSS vulnerability.
sub render_mutant_description {
	my ($id, $description, $difficulty, $hint) = @_;
	$id          = encode_entities($id          // 'unknown');
	$description = encode_entities($description // '');
	$difficulty  = encode_entities($difficulty  // '');
	$hint        = encode_entities($hint        // '');
	my $details = "<ul>\n";
	$details .= "<li><b>$id: $description</b><br>";
	$details .= "$difficulty: $hint\n";
	$details .= '</li>';
	$details .= "</ul>\n";
	return $details;
}

# ==================================================================
# PT — Path Traversal
# ==================================================================

subtest 'PT-01: _resolve_report_path rejects path with null byte' => sub {
	# A null-byte in a path is an injection technique that can trick
	# some languages into truncating filenames at the null.  Perl's
	# open() raises an exception for null bytes in filenames since 5.8.
	my $dir = tempdir(CLEANUP => 1);
	throws_ok(
		sub { _resolve_report_path($dir, "lib/Foo${NULL_BYTE}Bar.pm") },
		qr/suspicious|null|invalid|Null byte/i,
		'null byte in path is rejected'
	);
};

subtest 'PT-02: _resolve_report_path rejects CRLF in path' => sub {
	# A CRLF sequence could split an HTTP response header if the path
	# were ever reflected into a Location: or Content-Disposition: header.
	# Even in an HTML context, injecting a newline into a filename string
	# that is later used to open a file can produce unexpected filesystem
	# behaviour on some platforms.
	my $dir = tempdir(CLEANUP => 1);
	# CRLF-containing paths either croak or silently fail to write outside
	# the report dir.  Both outcomes are acceptable; writing outside is not.
	my $container = tempdir(CLEANUP => 1);
	my $report_dir = File::Spec->catdir($container, 'reports');
	mkdir $report_dir;

	eval { _resolve_report_path($report_dir, "lib/Foo${CRLF}Bar.pm") };
	# Whether it died or succeeded, nothing new should be outside $container/reports/
	opendir(my $dh, $container) or die $!;
	my @entries = sort grep { $_ ne '.' && $_ ne '..' } readdir $dh;
	closedir $dh;
	is_deeply(\@entries, ['reports'],
		'CRLF in path does not create files outside the report directory');
};

subtest 'PT-03: _resolve_report_path catches symlink escape (abs_path guard)' => sub {
	# A symlink inside the report directory that points outside it should
	# be caught by the abs_path-based containment check.
	my $container = tempdir(CLEANUP => 1);
	my $report_dir = File::Spec->catdir($container, 'rpt');
	mkdir $report_dir;

	# Create a symlink inside the report dir that points to the parent
	my $target_dir = tempdir(CLEANUP => 1);
	my $link_name  = File::Spec->catdir($report_dir, 'evil_link');
	symlink $target_dir, $link_name or skip('symlink not supported on this platform', 1);

	# Build a path that traverses through the symlink
	throws_ok(
		sub { _resolve_report_path($report_dir, 'evil_link/escaped_file.pm') },
		qr/Refusing to write report outside/,
		'abs_path guard catches symlink-based escape from report directory'
	);
};

# ==================================================================
# SH — Shell Safety
# ==================================================================

subtest 'SH-01: GUID with path traversal chars does not write outside reproduce/' => sub {
	# If $guid contained path-separator sequences, the resulting script
	# filename could resolve outside the reproduce/ directory.  The OS
	# open() will fail when intermediate directories don't exist, but
	# we explicitly confirm no file escapes the container.
	my $container = tempdir(CLEANUP => 1);

	for my $evil_guid ('../escape', '../../etc/passwd', 'a/../b/../../../tmp/evil') {
		my $report = { guid => $evil_guid, perl => '5.036', osname => 'linux' };
		generate_reproduction_script('My-Dist', '1.00', $report, {}, $container);
	}

	# Container directory should contain at most the reproduce/ subdir.
	# Files written INSIDE reproduce/ are acceptable (the open may have
	# failed silently); no files must appear BESIDE the container.
	my @top = do {
		opendir my $dh, $container or die $!;
		sort grep { $_ ne '.' && $_ ne '..' } readdir $dh;
	};
	# reproduce/ may or may not exist; only it is allowed.
	ok(
		@top == 0 || (@top == 1 && $top[0] eq 'reproduce'),
		'no files written outside reproduce/ when GUID contains traversal sequences'
	);
};

subtest 'SH-02: reporter field with shell backtick injection stays in comment line' => sub {
	# The reporter name is written into a # comment in the shell script.
	# Content in a comment cannot be executed, so backtick and $() injection
	# are inert — but we verify the characters appear verbatim so no
	# additional shell-level processing strips them silently.
	my $dir  = tempdir(CLEANUP => 1);
	my $guid = 'aabbccdd-0000-0000-0000-000000000001';
	generate_reproduction_script(
		'My-Dist', '1.00',
		{ guid => $guid, perl => '5.036', osname => 'linux',
		  reporter => "Alice $SHELL_BACKTICK Bob" },
		{},
		$dir,
	);
	my $path = File::Spec->catfile($dir, 'reproduce', "reproduce-$guid.sh");
	open my $fh, '<', $path or skip("script not written (open failed)", 1);
	my $content = do { local $/; <$fh> };
	close $fh;

	# Reporter line must be a comment — the backtick must not appear on
	# an uncommented executable line.
	my @exec_lines = grep { /\Q$SHELL_BACKTICK\E/ && !/^#/ } split /\n/, $content;
	is(scalar @exec_lines, 0,
		'backtick in reporter name does not appear on an executable shell line');
};

subtest 'SH-03: reporter field with $() injection stays in comment line' => sub {
	my $dir  = tempdir(CLEANUP => 1);
	my $guid = 'aabbccdd-0000-0000-0000-000000000002';
	generate_reproduction_script(
		'My-Dist', '1.00',
		{ guid => $guid, perl => '5.036', osname => 'linux',
		  reporter => "Alice $SHELL_DOLLAR_SUB Bob" },
		{},
		$dir,
	);
	my $path = File::Spec->catfile($dir, 'reproduce', "reproduce-$guid.sh");
	open my $fh, '<', $path or skip("script not written (open failed)", 1);
	my $content = do { local $/; <$fh> };
	close $fh;

	my @exec_lines = grep { /\Q$SHELL_DOLLAR_SUB\E/ && !/^#/ } split /\n/, $content;
	is(scalar @exec_lines, 0,
		'$() in reporter name does not appear on an executable shell line');
};

subtest 'SH-04: module version in cpanm line contains no shell metacharacters' => sub {
	# extract_installed_modules captures version strings with [\d._]+,
	# which truncates any appended metacharacters.  The module is still
	# captured — but with only the safe digit/dot/underscore prefix.
	# Because module names are then single-quoted in the cpanm line
	# (e.g. 'Foo::Bar@1.0'), the truncated safe version is what actually
	# reaches the shell.
	Readonly my @CASES => (
		[ '1.0;id',          '1.0',  'semicolon-appended injection truncated to safe prefix' ],
		[ '1.0`id`',         '1.0',  'backtick injection truncated to safe prefix' ],
		[ '1.0$(id)',         '1.0',  'dollar-paren injection truncated to safe prefix' ],
		[ "1.0\nrm -rf /",   '1.0',  'newline injection truncated to safe prefix' ],
	);

	for my $case (@CASES) {
		my ($bad_version, $expected, $label) = @$case;
		my $fake_html = "Installed modules:\n  Foo::Bar $bad_version\n\n";
		my $mods = extract_installed_modules($fake_html);
		if(exists $mods->{'Foo::Bar'}) {
			is($mods->{'Foo::Bar'}, $expected, $label);
			unlike($mods->{'Foo::Bar'}, qr/[;`\$\n]/,
				'captured version contains no shell metacharacters');
		} else {
			pass("$label (module rejected entirely — also safe)");
		}
	}
};

subtest 'SH-05: module name in cpanm line is validated to identifier pattern only' => sub {
	# extract_installed_modules requires module names to start with an
	# uppercase letter followed by word chars and optional ::Segments.
	# This prevents a crafted HTML report from injecting shell commands
	# into the cpanm --notest argument list.
	Readonly my @INJECTION_NAMES => (
		'foo::Bar',        # lowercase start — rejected by [A-Z] anchor
		'Foo-Bar',         # hyphen — not a word char
		"Foo::Bar;id",     # semicolon
		"Foo::Bar\`id\`",  # backtick
		'../Foo',          # path traversal
	);

	for my $bad_name (@INJECTION_NAMES) {
		my $fake_html = "Installed modules:\n  $bad_name 1.00\n\n";
		my $mods = extract_installed_modules($fake_html);
		ok(!exists $mods->{$bad_name},
			"module name '$bad_name' is rejected by extract_installed_modules");
	}
};

# ==================================================================
# XSS — Cross-site Scripting
# ==================================================================

subtest 'XSS-01: mutant description must be HTML-encoded in output' => sub {
	# _mutant_file_report inserts $m->{description} directly into an HTML
	# <li> element.  If the description contains a <script> tag it would
	# execute in any browser that opens the mutation report page.
	# This test confirms that the rendered output HTML-encodes the payload.
	my $html = render_mutant_description(
		'MUT_001',
		$XSS_SCRIPT_TAG,
		'medium',
		'some hint',
	);

	unlike($html, qr/\Q$XSS_SCRIPT_TAG\E/,
		'raw <script> tag is NOT present verbatim in description output');
	like($html, qr/&lt;script&gt;/,
		'<script> tag is HTML-entity encoded in description output');
};

subtest 'XSS-02: mutant hint must be HTML-encoded in output' => sub {
	# The same injection risk applies to $m->{hint}.
	my $html = render_mutant_description(
		'MUT_002',
		'normal description',
		'medium',
		$XSS_SCRIPT_TAG,
	);

	unlike($html, qr/\Q$XSS_SCRIPT_TAG\E/,
		'raw <script> tag is NOT present verbatim in hint output');
	like($html, qr/&lt;script&gt;/,
		'<script> tag is HTML-entity encoded in hint output');
};

subtest 'XSS-03: img onerror payload in description must not form a live HTML tag' => sub {
	# <img src=x onerror=alert(1)> is dangerous only when the browser
	# parses an unencoded '<img' tag.  encode_entities converts '<' to
	# '&lt;', so the tag never opens.  Verify the opening '<img' is gone.
	my $html = render_mutant_description(
		'MUT_003',
		$XSS_IMG_ONERROR,
		'low',
		'hint text',
	);

	unlike($html, qr/<img/i,
		'<img tag opener is not present unencoded — browser cannot fire onerror');
	like($html, qr/&lt;img/i,
		'img tag is HTML-entity encoded');
};

subtest 'XSS-04: mutant id must be HTML-safe in output' => sub {
	# Mutant IDs are generated by the mutation engine and should be
	# identifier-like, but a malicious mutation.json could supply
	# arbitrary values.  Confirm the id is not reflected unencoded.
	my $xss_id = $XSS_SCRIPT_TAG;
	my $html = render_mutant_description(
		$xss_id,
		'description',
		'low',
		'hint',
	);

	unlike($html, qr/\Q$xss_id\E/,
		'XSS payload in mutant id is not reflected unencoded');
};

subtest 'XSS-05: js_escape defends against JS string break-out' => sub {
	# js_escape is used for strings placed inside double-quoted JS literals.
	# A double-quote or backslash in input must be escaped so the
	# surrounding JS string cannot be terminated prematurely.
	Readonly my @CASES => (
		[ q{"},          q{\\"},   'double-quote escaped' ],
		[ q{\\},         q{\\\\},  'backslash doubled' ],
		[ "line1\nline2", 'line1\\nline2', 'newline escaped' ],
	);
	for my $case (@CASES) {
		my ($input, $expected_substr, $label) = @$case;
		my $out = js_escape($input);
		ok(index($out, $expected_substr) >= 0, $label);
	}
};

subtest 'XSS-06: js_escape does not double-encode already-escaped content' => sub {
	# Confirm that a plain safe string passes through unchanged — js_escape
	# is not an HTML encoder; it must not mangle safe identifiers.
	my $safe = 'hello world 123';
	is(js_escape($safe), $safe, 'safe string unchanged by js_escape');
};

# ==================================================================
# HI — Header Injection
# ==================================================================

subtest 'HI-01: CRLF in GUID does not produce multi-line HTTP-style header in script' => sub {
	# Although the output is a shell script (not an HTTP response), a CRLF
	# in the GUID could produce a line that breaks out of the comment block
	# if the comment contains the GUID literally.
	my $dir      = tempdir(CLEANUP => 1);
	my $bad_guid = "legit-guid${CRLF}X-Evil-Header: injected";
	my $report   = { guid => $bad_guid, perl => '5.036', osname => 'linux' };
	generate_reproduction_script('My-Dist', '1.00', $report, {}, $dir);

	# Either the open failed (injected CRLF in path) or the file was
	# written with the CRLF inside a comment.  In either case, the
	# string 'X-Evil-Header:' must NOT appear on a non-comment executable line.
	my $script = File::Spec->catfile($dir, 'reproduce', "reproduce-${bad_guid}.sh");
	if(-f $script) {
		open my $fh, '<', $script or die $!;
		my $content = do { local $/; <$fh> };
		close $fh;
		my @exec_lines = grep { /X-Evil-Header:/ && !/^#/ } split /\n/, $content;
		is(scalar @exec_lines, 0,
			'CRLF in GUID does not produce an executable line with injected content');
	} else {
		pass('script not written — open() rejected CRLF in filename (safe)');
	}
};

done_testing();
