view release on metacpan or  search on metacpan

t/cgi_security.t  view on Meta::CPAN

my $HAS_JSON = eval { require JSON::Parse;             1 } ? 1 : 0;

BEGIN { use_ok('CGI::Lingua') }

# ── Constants ─────────────────────────────────────────────────────────────────

# Maximum header length accepted by the module (matches $ACCEPT_LANG_MAX).
Readonly my $MAX_HEADER_LEN => 256;

# A public IP that is neither private nor loopback, used when a real IP is needed.
Readonly my $PUBLIC_IP => '8.8.8.8';

# Shell metacharacter payloads; each must be rejected at the env-var layer.
# NOTE: ';' and whitespace ARE valid in Accept-Language (used for q-values),
# so 'en; ls -la' and 'en\tls' are intentionally omitted — they pass the
# untaint regex legitimately and never reach a shell.
Readonly my @SHELL_PAYLOADS => (
	'en|cat /etc/passwd',
	'en$(id)',
	'en`id`',
	'en && evil',
);

# CRLF injection payloads; none must survive into returned data.
Readonly my @CRLF_PAYLOADS => (
	"en\r\nX-Injected: evil",
	"en\nX-Injected: evil",
	"en\rX-Injected: evil",
);

# ── Network block ─────────────────────────────────────────────────────────────

# Block all real network I/O for the entire file.  Subtests that need specific
# whois/geoplugin behaviour override locally before restoring.
Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois', sub { });
Test::Mockingbird::mock('LWP::Simple::WithCache', 'get', sub { undef }) if $HAS_LWP;

# Restore the global network block after restore_all() in any subtest.
sub _block_network {
	Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois', sub { });
	Test::Mockingbird::mock('LWP::Simple::WithCache', 'get', sub { undef })
		if $HAS_LWP;
}

# Build a minimal CGI::Lingua object with the global network block active.
sub _obj {
	my (%extra) = @_;
	CGI::Lingua->new(supported => ['en', 'fr', 'de', 'en-gb'], %extra);
}

# ── 1. Shell metacharacter injection via HTTP_ACCEPT_LANGUAGE ─────────────────
# The regex /^([A-Za-z0-9\-,;=.*\s]{1,256})$/a must reject every shell meta.
# If any payload leaked, it could reach I18N::AcceptLanguage's regex engine or
# be stored in the object and later reflected.

subtest 'Accept-Language: shell metacharacters are rejected by untaint regex' => sub {
	for my $payload (@SHELL_PAYLOADS) {
		local %ENV = (HTTP_ACCEPT_LANGUAGE => $payload, REMOTE_ADDR => '127.0.0.1');
		my $l = _obj();
		# language() must fall through to 'Unknown'; it must NOT return or store
		# any fragment of the hostile payload.
		my $lang = $l->language();
		is($lang, 'Unknown', "shell payload rejected: " . _abbrev($payload));
		unlike($lang // '', qr/[|;&\x60\$]/, 'no shell meta in returned language');
	}
};

# ── 2. CRLF injection via HTTP_ACCEPT_LANGUAGE ────────────────────────────────
# A browser forging a CRLF-bearing Accept-Language header could attempt to
# inject extra HTTP response headers when the application reflects the header.

subtest 'Accept-Language: CRLF sequences are rejected by untaint regex' => sub {
	for my $payload (@CRLF_PAYLOADS) {
		local %ENV = (HTTP_ACCEPT_LANGUAGE => $payload, REMOTE_ADDR => '127.0.0.1');
		my $l   = _obj();
		my $lang = $l->language();
		is($lang, 'Unknown', 'CRLF payload rejected in Accept-Language');

		# The requested_language() result must not contain a bare CRLF either.
		my $rl = $l->requested_language();
		unlike($rl // '', qr/[\r\n]/, 'CRLF not in requested_language() output');
	}
};

# ── 3. Null-byte injection via HTTP_ACCEPT_LANGUAGE ───────────────────────────
# Null bytes (\x00) can truncate C strings and confuse pattern matchers.

subtest 'Accept-Language: null byte is rejected' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => "en\x00evil", REMOTE_ADDR => '127.0.0.1');
	my $l = _obj();
	is($l->language(), 'Unknown', 'Null byte in Accept-Language rejected');
};

# ── 4. Overlength Accept-Language header ──────────────────────────────────────
# Headers longer than $ACCEPT_LANG_MAX must be silently dropped, not truncated.
# Truncation can produce a syntactically valid but semantically different value.

subtest 'Accept-Language: header exactly at limit is accepted' => sub {
	# Construct a valid header that is exactly 256 characters.
	# Use "en" repeated with commas to fill the space.
	my $at_limit = 'en' . (',en' x (($MAX_HEADER_LEN - 2) / 3));
	$at_limit = substr($at_limit, 0, $MAX_HEADER_LEN);
	local %ENV = (HTTP_ACCEPT_LANGUAGE => $at_limit);
	my $l = _obj();
	# Must process normally (not crash, not warn about invalid chars).
	lives_ok { $l->language() } 'header at limit does not crash';
};

subtest 'Accept-Language: header one byte over limit is rejected' => sub {
	my $over = 'en' . ('a' x ($MAX_HEADER_LEN - 1));    # 257 chars
	local %ENV = (HTTP_ACCEPT_LANGUAGE => $over, REMOTE_ADDR => '127.0.0.1');
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, (ref($_[1]) ? $_[1]->{warning} : $_[1]) });
	my $l = _obj();
	$l->language();
	my $warned = grep { /invalid characters/ } @warnings;
	ok($warned, 'overlength header triggers invalid-characters warning');
	Test::Mockingbird::restore_all();
	_block_network();
};

t/cgi_security.t  view on Meta::CPAN

			'Shell meta in GEOIP_COUNTRY_CODE not returned: ' . _abbrev($code));
		Test::Mockingbird::restore_all();
		_block_network();
	}
};

subtest 'GEOIP_COUNTRY_CODE: wrong-length codes are rejected' => sub {
	for my $code ('G', 'GBR', 'GBGB', '', '1U', 'gb') {
		# Code must be exactly 2 UPPERCASE ASCII letters to pass
		local %ENV = (GEOIP_COUNTRY_CODE => $code, REMOTE_ADDR => '127.0.0.1');
		my @warnings;
		Test::Mockingbird::mock('CGI::Lingua', '_warn',
			sub { push @warnings, (ref($_[1]) ? $_[1]->{warning} : $_[1]) });
		my $l  = _obj();
		my $cc = $l->country();
		# Valid 2-uppercase result must not come back if the code is wrong format
		if(defined $cc) {
			unlike($cc, qr/[^a-z]/, "Non-alpha chars not in returned code for: $code");
		} else {
			pass("GEOIP_COUNTRY_CODE '$code' correctly rejected");
		}
		Test::Mockingbird::restore_all();
		_block_network();
	}
};

# ── 8. HTTP_CF_IPCOUNTRY format violations ────────────────────────────────────
# Same /^([A-Z]{2})$/a validation as GEOIP_COUNTRY_CODE; same attack surface.

subtest 'HTTP_CF_IPCOUNTRY: CRLF injection is rejected' => sub {
	local %ENV = (HTTP_CF_IPCOUNTRY => "FR\r\nX-Inject: malicious");
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, (ref($_[1]) ? $_[1]->{warning} : $_[1]) });
	my $l = _obj();
	$l->country();
	ok((grep { /invalid country code/ } @warnings),
		'CRLF in HTTP_CF_IPCOUNTRY triggers warning');
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest 'HTTP_CF_IPCOUNTRY: Cloudflare XX sentinel not returned as country code' => sub {
	# 'XX' is a documented special value meaning "Cloudflare could not determine
	# country".  It must not be returned to the caller as a country code.
	local %ENV = (HTTP_CF_IPCOUNTRY => 'XX', REMOTE_ADDR => '127.0.0.1');
	my $l  = _obj();
	my $cc = $l->country();
	ok(!defined $cc || $cc ne 'xx',
		'Cloudflare XX sentinel not returned as country');
};

# ── 9. LANG env-var injection ─────────────────────────────────────────────────
# LANG is only consulted when HTTP_ACCEPT_LANGUAGE and the CGI::Info lang param
# are both absent (local/debug mode).  It is untainted by a similar regex.

subtest 'LANG: shell metacharacters are ignored' => sub {
	for my $payload ('en_US; rm -rf /', "en_US\r\nX-Header: evil", "en_US\x00") {
		local %ENV = (LANG => $payload, REMOTE_ADDR => '127.0.0.1');
		my $l = _obj();
		# language() must not expose any fragment of the payload
		my $lang = $l->language();
		unlike($lang // '', qr/[|;&\x60\$\r\n\x00]/, "LANG payload not reflected: " . _abbrev($payload));
	}
};

# ── 10. HTTP_USER_AGENT CRLF injection (locale() path) ───────────────────────
# locale() parses the User-Agent parenthetical for a language tag.  A crafted
# UA with CRLF could attempt to split the match and inject data.

subtest 'HTTP_USER_AGENT: CRLF in parenthetical does not leak into locale()' => sub {
	# The regex /\((.+)\)/ uses `.` which does NOT match \n in default mode,
	# so CRLF terminates the match before the injected header.
	local %ENV = (
		HTTP_USER_AGENT => "Mozilla/5.0 (en-GB\r\nX-Injected: evil)",
		REMOTE_ADDR     => '127.0.0.1',
	);
	my $l      = _obj();
	my $locale = $l->locale();
	# If locale() returned anything, its name() must not contain CRLF sequences
	if(defined $locale && blessed $locale) {
		my $name = $locale->name() // '';
		unlike($name, qr/[\r\n]/, 'CRLF not in locale name from UA');
	} else {
		pass('locale() returned undef for CRLF UA — safe degradation');
	}
};

subtest 'HTTP_USER_AGENT: XSS payload in parenthetical does not match lang-tag regex' => sub {
	# The lang-tag check requires /^[a-zA-Z]{2}-([a-zA-Z]{2})$/, so an XSS
	# payload like "<script>alert(1)</script>" will never pass.
	local %ENV = (
		HTTP_USER_AGENT => 'Mozilla/5.0 (<script>alert(1)</script>)',
		REMOTE_ADDR     => '127.0.0.1',
	);
	my $l      = _obj();
	my $locale = $l->locale();
	if(defined $locale && blessed $locale) {
		unlike($locale->name() // '', qr/<script>/i,
			'XSS payload not reflected in locale name');
	} else {
		pass('locale() returned undef for XSS UA — safe');
	}
};

subtest 'HTTP_USER_AGENT: null byte in parenthetical does not match lang-tag' => sub {
	local %ENV = (
		HTTP_USER_AGENT => "Mozilla/5.0 (en-G\x00B)",
		REMOTE_ADDR     => '127.0.0.1',
	);
	my $l      = _obj();
	my $locale = $l->locale();
	# A null byte breaks the 2-letter country code match; locale() must return undef
	# or a locale that came from a different detection path (IP or GEOIP_COUNTRY_CODE).
	pass('locale() did not crash on null byte in UA');
};

# ── 11. Whois response injection (_clean_country_code) ───────────────────────
# If an attacker controls the upstream Whois server (MITM), they can inject
# arbitrary bytes into the country field of the response.  _clean_country_code()
# strips CRLFs and trailing comments; the final result must be safe.