CGI-Lingua
22 results

 view release on metacpan or  search on metacpan

t/cgi_security.t  view on Meta::CPAN 

#!/usr/bin/env perl
# t/cgi_security.t -- Penetration / security regression tests for CGI::Lingua.
#
# Simulates hostile CGI environments by injecting weaponised payloads into
# the five env vars the module reads:
#
#   HTTP_ACCEPT_LANGUAGE  REMOTE_ADDR  GEOIP_COUNTRY_CODE
#   HTTP_CF_IPCOUNTRY     LANG         HTTP_USER_AGENT
#
# Each subtest documents the specific exploit mechanism being attempted and
# asserts that the module fails securely (rejects, warns, returns undef)
# rather than passing hostile data downstream.
#
# Attack categories covered:
#   1. Shell metacharacter / command injection via env vars
#   2. CRLF / header injection via env vars
#   3. Null-byte injection
#   4. Overlength header (DoS / buffer edge)
#   5. Country-code format violations (length, non-alpha, embedded control chars)
#   6. IP address format violations (path traversal, shell meta in REMOTE_ADDR)
#   7. Whois response injection (CRLF, trailing-comment bypass, MITM data)
#   8. JSON API response injection (XSS payload in country/timezone fields)
#   9. Cache key poisoning (namespace prefix collision, split() separator abuse)
#  10. HTTP_USER_AGENT CRLF and XSS injection (locale() path)
#  11. Accept-Language q-value boundary and wildcard edge cases
#  12. IPv4-mapped IPv6 normalisation correctness
#  13. Translation-file extension path-traversal guard
#  14. Country-code output validation (final result must be 2 lowercase alpha)

use strict;
use warnings;

use CHI;
use File::Temp qw(tempdir);
use Readonly;
use Scalar::Util qw(blessed);
use Test::Most;
use Test::Mockingbird;
use Test::Returns qw(returns_ok);

# Pre-require LWP::Simple::WithCache and JSON::Parse before any mocks are
# installed.  Their BEGIN blocks run on first require and clobber any existing
# symbol-table entry, including mocks.  Loading them here makes all subsequent
# eval { require ... } calls inside country() and time_zone() no-ops that
# leave Test::Mockingbird mocks intact.
my $HAS_LWP  = eval { require LWP::Simple::WithCache; 1 } ? 1 : 0;
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.

t/cgi_security.t  view on Meta::CPAN 

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.

subtest '_clean_country_code: strips carriage returns from whois response' => sub {
	# Simulate a whois response with an embedded carriage return.
	# Real example: some servers return "GB\r" in the Country field.
	Test::Mockingbird::unmock('CGI::Lingua', '_resolve_country_via_whois');
	Test::Mockingbird::mock('Net::Whois::IP', 'whoisip_query', sub {
		return { Country => "GB\r" };
	});
	local %ENV = (REMOTE_ADDR => $PUBLIC_IP);
	my $l = _obj();
	$l->{_have_ipcountry} = 0;
	$l->{_have_geoip}     = 0;
	$l->{_have_geoipfree} = 0;
	my $cc = $l->country();
	# The \r must be stripped; country must be a clean 2-char code or undef
	if(defined $cc) {
		unlike($cc, qr/[\r\n]/, 'Carriage return stripped from whois country');
		is(length($cc), 2, 'Country code is exactly 2 chars after CR strip');
	} else {
		pass('country() returned undef after CR in whois (acceptable fallback)');
	}
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest '_clean_country_code: strips trailing # comment from whois response' => sub {
	# Some whois servers append a comment after the code: "US # United States"
	Test::Mockingbird::unmock('CGI::Lingua', '_resolve_country_via_whois');
	Test::Mockingbird::mock('Net::Whois::IP', 'whoisip_query', sub {
		return { Country => 'US # United States via ARIN' };
	});
	local %ENV = (REMOTE_ADDR => $PUBLIC_IP);
	my $l = _obj();
	$l->{_have_ipcountry} = 0;
	$l->{_have_geoip}     = 0;
	$l->{_have_geoipfree} = 0;
	my $cc = $l->country();
	if(defined $cc) {
		is($cc, 'us', 'Trailing # comment stripped; code is lowercase us');
	} else {
		pass('country() returned undef (geoplugin mock suppressed data)');
	}
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest '_clean_country_code: CRLF + injected header does not propagate' => sub {
	# MITM whois server injects "GB\nX-Header: evil" as Country field.
	# After s/[\r\n]//g the value becomes "GBX-Header: evil" — too long and
	# containing non-alpha chars.  country() MUST NOT return this to the caller.
	Test::Mockingbird::unmock('CGI::Lingua', '_resolve_country_via_whois');
	Test::Mockingbird::mock('Net::Whois::IP', 'whoisip_query', sub {
		return { Country => "GB\nX-Header: evil" };
	});



( run in 0.700 second using v1.01-cache-2.11-cpan-a5162978ef8 )