view release on metacpan or  search on metacpan

t/cgi_security.t  view on Meta::CPAN

subtest 'ATTACK: wildcard literal "*" returned by lingua->country()' => sub {
	# Exploit: if lingua returns '*', and the code compared it against the
	# deny_countries wildcard sentinel before lowercasing, an attacker might
	# trigger the wildcard-deny branch without being in the allow list.
	# All country codes from lingua are treated as plain strings; only the
	# explicitly stored wildcard sentinel activates default-deny mode.
	my $acl  = CGI::ACL->new()->deny_country('*');
	my $ling = Test::PenLingua->new('*');
	# '*' is falsy-ish only if undef/0/""; '*' is truthy in Perl so it passes
	# the `$country = $country_val or return 1` guard.  lc('*') = '*'.
	# deny_countries->{'*'} IS set (wildcard mode).  allow_countries->{'*'}
	# is NOT set.  Result: deny.
	is(denied_at($acl, $SAFE_IP, lingua => $ling), 1,
		'wildcard "*" from lingua is not a self-grant; deny_country("*") still enforced');
};

subtest 'ATTACK: very long country code from lingua->country()' => sub {
	# Exploit: a 64 KiB country code compared via a hash lookup is O(1) after
	# lc().  No ReDoS or OOM risk, but we confirm timing stays sub-second.
	my $acl   = CGI::ACL->new()->deny_country('cn');
	my $ling  = Test::PenLingua->new('x' x 65536);
	my $start = time();
	my $result = denied_at($acl, $SAFE_IP, lingua => $ling);
	my $elapsed = time() - $start;
	is($result, 0,          'overlong country code is not in deny list => allowed');
	ok($elapsed < 2,        "overlong country evaluated quickly (${elapsed}s)");
};

# =============================================================================
# GROUP 6 — Cloud hostname injection via mock DNS
#
# An attacker controlling a DNS server could return a hostile PTR record.
# CGI::ACL only does string comparison against @CLOUD_PATTERNS — it never
# passes the hostname to shell or file operations.  We verify the RFC 1035
# length guard and that embedded special characters cause no harm.
# =============================================================================

subtest 'ATTACK: PTR record exceeding RFC 1035 253-char limit is rejected' => sub {
	# Exploit: a 300-char hostname that embeds a cloud-provider pattern beyond
	# the 253-char bound.  The length check must fire before any regex matching,
	# preventing a compromised resolver from forcing a cloud match via a very
	# long hostname.
	ok(length($LONG_HOST) > 253, 'precondition: LONG_HOST exceeds 253 chars');
	my $long_guard = mock_scoped 'CGI::ACL::_verified_rdns' => sub { $LONG_HOST };
	my $acl = CGI::ACL->new()->deny_cloud();
	# DNS mock returns $LONG_HOST; RFC 1035 check must reject it => non-cloud => allow
	is(denied_at($acl, $CLOUD_IP), 0,
		'overlong PTR hostname rejected by RFC 1035 check; IP treated as non-cloud');
};

subtest 'ATTACK: PTR record with shell metacharacters (command injection via hostname)' => sub {
	# Exploit: if _is_cloud_host() or any downstream caller ever passed the
	# hostname to system() or 2-arg open(), a PTR like
	# "ec2.amazonaws.com; id" would execute arbitrary commands.
	# CGI::ACL only performs a regex match; the hostname is never shelled.
	my $shell_host = 'ec2-1-2-3-4.compute-1.amazonaws.com; cat /etc/passwd';
	my $inject_guard = mock_scoped 'CGI::ACL::_verified_rdns' => sub { $shell_host };
	my $acl    = CGI::ACL->new()->deny_cloud();
	my $result = eval { denied_at($acl, $CLOUD_IP) };
	ok(!$@, 'shell-metachar PTR hostname does not cause an exception');
	pass('no command was executed; test process alive after shell payload in PTR');
};

subtest 'ATTACK: PTR record with CRLF sequence (header-splitting via DNS)' => sub {
	# Exploit: \r\n in a PTR record could split HTTP headers if the hostname
	# were ever emitted in a response.  CGI::ACL does not output the hostname.
	# We verify no exception is raised.
	my $crlf_host  = "ec2.compute-1.amazonaws.com\r\nX-Injected: pwned";
	my $crlf_guard = mock_scoped 'CGI::ACL::_verified_rdns' => sub { $crlf_host };
	my $acl    = CGI::ACL->new()->deny_cloud();
	my $result = eval { denied_at($acl, $CLOUD_IP) };
	ok(!$@, 'CRLF-embedded PTR hostname does not cause an exception');
};

# =============================================================================
# GROUP 7 — Type confusion attacks on setter methods
#
# Passing unexpected reference types to allow_ip(), deny_country(), and
# allow_country() must produce a carp and return $self — never return undef
# (which would break method chaining with a cryptic "can't call method on
# undefined value" crash).
# =============================================================================

subtest 'ATTACK: arrayref passed to allow_ip() (type confusion)' => sub {
	my $acl = CGI::ACL->new();
	my $ret;
	does_carp(sub { $ret = $acl->allow_ip([$SAFE_IP]) });
	is($ret, $acl, 'allow_ip returns $self on arrayref argument (chain preserved)');
};

subtest 'ATTACK: coderef passed to deny_country() (type confusion)' => sub {
	my $acl = CGI::ACL->new();
	my $ret;
	does_carp(sub { $ret = $acl->deny_country(sub { 'CN' }) });
	is($ret, $acl, 'deny_country returns $self on coderef argument (chain preserved)');
};

subtest 'ATTACK: typeglob passed to allow_country() (glob injection)' => sub {
	my $acl = CGI::ACL->new();
	my $ret;
	does_carp(sub { $ret = $acl->allow_country(\*STDIN) });
	is($ret, $acl, 'allow_country returns $self on glob argument (chain preserved)');
};

# =============================================================================
# GROUP 8 — all_denied() lingua type confusion
#
# The `lingua` argument must be a blessed object with a country() method.
# Passing any other type must carp and return 1 (deny) without an exception.
# =============================================================================

subtest 'ATTACK: scalar string passed as lingua' => sub {
	my $acl = CGI::ACL->new()->deny_country('cn');
	does_carp(sub {
		is(denied_at($acl, $SAFE_IP, lingua => 'not-an-object'), 1,
			'scalar lingua causes deny');
	});
};

subtest 'ATTACK: unblessed hashref passed as lingua' => sub {
	my $acl = CGI::ACL->new()->deny_country('cn');