view release on metacpan or  search on metacpan

t/cgi_security.t  view on Meta::CPAN

	# were ever reflected.  The second "IP" after the newline must not be
	# evaluated as an IP — the entire string must fail validation.
	my $acl = CGI::ACL->new()->allow_ip($SAFE_IP_2);
	is(denied_at($acl, $CRLF_IP), 1, 'CRLF-embedded REMOTE_ADDR rejected before any header reflection');
};

subtest 'ATTACK: null-byte in REMOTE_ADDR (C-string termination bypass)' => sub {
	# Exploit: C-library string functions stop at \x00.  The format validator
	# must reject the whole string, not truncate and evaluate "1.2.3.4".
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, $NULL_IP), 1, 'null-byte embedded IP rejected by format validator');
};

subtest 'ATTACK: shell metacharacters in REMOTE_ADDR (command injection probe)' => sub {
	# Exploit: if REMOTE_ADDR were ever passed to system() or 2-arg open(),
	# shell metacharacters would execute arbitrary commands.  The format
	# validator must reject all of these before they enter the data flow.
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	for my $payload ($SHELL_META, $BACKTICK, $DOLLAR_SUB, $PIPE) {
		is(denied_at($acl, $payload), 1,
			'shell metachar payload rejected: ' . substr($payload, 0, 30));
	}
};

subtest 'ATTACK: SQL injection string in REMOTE_ADDR' => sub {
	# Exploit: REMOTE_ADDR interpolated into a SQL query without validation.
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, $SQL_INJECT), 1, 'SQL injection string rejected as non-IP');
};

subtest 'ATTACK: XSS payload in REMOTE_ADDR' => sub {
	# Exploit: REMOTE_ADDR reflected into an access-denied page without
	# HTML-encoding.  The ACL must reject it at the format stage so it
	# never reaches any output path.
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, $XSS_INJECT), 1, 'XSS payload in REMOTE_ADDR rejected');
};

subtest 'ATTACK: path traversal in REMOTE_ADDR' => sub {
	# Exploit: REMOTE_ADDR used to build a file path (e.g. log file named
	# after the IP).  The format validator must reject it before it reaches
	# any file-handling code.
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, $PATH_TRVS), 1, 'path traversal in REMOTE_ADDR rejected');
};

subtest 'ATTACK: overlong REMOTE_ADDR (catastrophic backtracking / OOM probe)' => sub {
	# Exploit: a 64 KiB non-IP string fed to a poorly-bounded regex could
	# cause catastrophic backtracking and hang the CGI process.  Regexp::Common
	# patterns are well-anchored, but we confirm the call returns promptly.
	my $acl   = CGI::ACL->new()->allow_ip($LOOPBACK);
	my $start = time();
	my $result = denied_at($acl, $LONG_ADDR);
	my $elapsed = time() - $start;
	is($result, 1, 'overlong REMOTE_ADDR denied');
	ok($elapsed < 5, "evaluated in under 5 s (elapsed: ${elapsed}s)");
};

subtest 'ATTACK: Unicode characters in REMOTE_ADDR' => sub {
	# Exploit: wide characters or multi-byte sequences in REMOTE_ADDR could
	# corrupt length-based checks or confuse locale-sensitive regex engines.
	my $acl    = CGI::ACL->new()->allow_ip($LOOPBACK);
	my $result = eval { denied_at($acl, "\x{e9}vil.host") };
	ok(!$@,        'Unicode REMOTE_ADDR does not throw an exception');
	is($result, 1, 'Unicode REMOTE_ADDR is denied');
};

subtest 'ATTACK: empty-string REMOTE_ADDR (defined-or vs. logical-or regression)' => sub {
	# Exploit: the old code used `|| $DEFAULT_ADDR`, which substituted loopback
	# for any falsy value including "".  Fixed to `// $DEFAULT_ADDR`.
	# An empty string must be rejected as an invalid IP, not silently treated
	# as loopback (which would grant access if loopback is in the allow list).
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, ''), 1, 'empty REMOTE_ADDR denied; loopback not substituted');
};

subtest 'ATTACK: REMOTE_ADDR="0" (falsy string, old || bug)' => sub {
	# Exploit: the old `|| $DEFAULT_ADDR` would silently substitute loopback
	# for the Perl-falsy string "0", granting access when loopback is allowed.
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, '0'), 1, '"0" REMOTE_ADDR denied; not substituted with loopback');
};

subtest 'ATTACK: REMOTE_ADDR with trailing comment (format bypass probe)' => sub {
	# Probe: "203.0.113.1 # injected" — the space makes the whole string
	# syntactically invalid as an IP.  Must be rejected entirely.
	my $acl = CGI::ACL->new()->allow_ip($SAFE_IP);
	is(denied_at($acl, "$SAFE_IP # injected"), 1, 'IP with trailing comment rejected');
};

subtest 'ATTACK: out-of-range IPv4 octet in REMOTE_ADDR' => sub {
	# Probe: octets above 255 are not valid IPv4; some naive validators
	# accept them or wrap them modulo 256.
	my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
	is(denied_at($acl, '999.999.999.999'), 1, 'out-of-range octet rejected');
	is(denied_at($acl, '256.0.0.1'),       1, 'octet 256 rejected');
	is(denied_at($acl, '192.168.1.256'),   1, 'trailing octet 256 rejected');
};

# =============================================================================
# GROUP 2 — Cloud cache injection via environment variables
#
# Object::Configure reads CGI__ACL__KEY environment variables and merges them
# into the constructor's initial state.  Before the 0.10 fix, setting
# CGI__ACL___cloud_cache could pre-seed the DNS cache so that a cloud IP
# appeared non-cloud for the lifetime of the process.
# =============================================================================

subtest 'ATTACK: CGI__ACL___cloud_cache env-var injection (class constructor path)' => sub {
	# Exploit: inject a cache entry marking $CLOUD_IP as non-cloud with a
	# far-future expiry.  If _* stripping is absent, all_denied() consults
	# the injected entry and returns 0 (allow) for the cloud IP.
	local %ENV;
	clean_env();
	$ENV{'CGI__ACL___cloud_cache'} = 'injected';	# value irrelevant; key must be stripped
	$ENV{REMOTE_ADDR} = $CLOUD_IP;

	my $acl = CGI::ACL->new()->deny_cloud();
	ok(!defined($acl->{_cloud_cache}),
		'_cloud_cache env-var injection stripped from class constructor');
	is($acl->all_denied(), 1,