view release on metacpan or  search on metacpan

t/cgi_security.t  view on Meta::CPAN

	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{REMOTE_ADDR}       = $REMOTE;
	$ENV{HTTP_USER_AGENT}   = $SQL_UA_INJECTION;
	$ENV{QUERY_STRING}      = 'q=hello';

	my $info = CGI::Info->new();
	my $is_robot = $info->is_robot();
	is($info->status(), $STATUS_FORBIDDEN,
		'SQL-injected User-Agent triggers 403 via is_robot()');
	ok($is_robot, 'is_robot() returns true for SQL-injected UA');
};

subtest 'SQL UA: ORDER BY in User-Agent blocked' => sub {
	reset_env();
	$ENV{REMOTE_ADDR}       = $REMOTE;
	$ENV{HTTP_USER_AGENT}   = 'Fakebot/1.0 ORDER BY 1--';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'x=1';

	my $info = CGI::Info->new();
	$info->is_robot();
	is($info->status(), $STATUS_FORBIDDEN,
		'User-Agent with ORDER BY triggers 403');
};

subtest 'SQL UA: AND N=N in User-Agent blocked' => sub {
	reset_env();
	$ENV{REMOTE_ADDR}       = $REMOTE;
	$ENV{HTTP_USER_AGENT}   = 'TestBot AND 1=1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{QUERY_STRING}      = 'x=1';

	my $info = CGI::Info->new();
	$info->is_robot();
	is($info->status(), $STATUS_FORBIDDEN,
		'User-Agent with AND N=N triggers 403');
};

# ---------------------------------------------------------------------------
# Section 5: XSS injection via GET query string
# Known-working and known-bypass patterns.
# ---------------------------------------------------------------------------

subtest 'XSS: <script> tag blocked in GET' => sub {
	my $info = make_get("q=$XSS_SCRIPT_TAG");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'<script>alert(1)</script> triggers 403');
};

subtest 'XSS: <img onerror> blocked in GET' => sub {
	my $info = make_get("q=$XSS_IMG_ONERROR");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'<img onerror=...> triggers 403');
};

subtest 'XSS: URL-encoded <script> blocked in GET' => sub {
	# %3Cscript%3E decoded to <script> by URL-decode pass, then caught.
	my $info = make_get("q=$XSS_URL_ENCODED");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'URL-encoded <script> tag triggers 403');
};

subtest 'XSS: <svg onload=> blocked in GET' => sub {
	my $info = make_get("q=$XSS_SVG_ONLOAD");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'<svg onload=alert(1)> triggers 403');
};

subtest 'XSS: multi-line <img> tag blocked' => sub {
	# Fixed: replaced [^\n]+ with .+ and added /s flag so the dot matches
	# newlines.  "<img\nsrc=x\nonerror=alert(1)>" is now caught.
	my $payload = $XSS_IMG_MULTILINE;
	my $info = make_get("q=$payload");
	my $p = $info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'multi-line <img\\nsrc=x onerror=...> is blocked with 403');
	ok(!defined $p, 'params() returns undef for multi-line XSS');
};

subtest 'XSS: javascript: URI blocked' => sub {
	# Fixed: added /\bjavascript\s*:/i check before the mustleak/traversal
	# checks.  A "javascript:" URI triggers XSS in href/src even without <>.
	my $info = make_get("url=$XSS_JAVASCRIPT_URI");
	my $p = $info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'javascript: URI is blocked with 403');
};

subtest 'XSS: double-URL-encoded script tag blocked' => sub {
	# Fixed: added a second URL-decode pass so %252F -> %2F -> / and
	# %253C -> %3C -> < are both normalised before WAF checks run.
	my $info = make_get("q=$XSS_DOUBLE_ENCODED");
	my $p = $info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'double-encoded <script> (%253C) is blocked with 403');
};

# ---------------------------------------------------------------------------
# Section 6: Path traversal via GET query string
# ---------------------------------------------------------------------------

subtest 'Traversal: classic ../ blocked in GET' => sub {
	my $info = make_get("file=$TRAV_CLASSIC");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'../../../etc/passwd triggers 403');
};

subtest 'Traversal: URL-encoded ..%2F blocked in GET' => sub {
	# ..%2F is decoded to ../ in a single pass, then caught.
	my $info = make_get("file=$TRAV_URL_ENCODED");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'..%2Fetc%2Fpasswd triggers 403');
};

subtest 'Traversal: double-encoded ..%252F blocked' => sub {
	# Fixed: second URL-decode pass normalises %252F -> %2F -> / so
	# the resulting ../ is caught by the traversal check.
	my $info = make_get("file=$TRAV_DOUBLE_ENCODED");
	my $p = $info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'double-encoded ..%252F is blocked with 403');
	ok(!defined $p, 'params() returns undef for double-encoded traversal');
};

subtest 'Traversal: null-byte poisoning stripped then caught' => sub {
	# NUL bytes are stripped before the traversal check, so
	# "../etc/passwd\0.jpg" becomes "../etc/passwd.jpg" and is still caught.
	my $payload = '../etc/passwd%00.jpg';
	my $info = make_get("file=$payload");
	$info->params();
	is($info->status(), $STATUS_FORBIDDEN,
		'NUL-poisoned path traversal (%00) is still blocked with 403');
};

subtest 'Traversal: Windows backslash path not blocked (forward-slash only) [DESIGN]' => sub {
	# The traversal regex checks /\.\.\// (forward slash only).
	# ..\..\..\windows\... on Windows is not caught.
	# Note: CGI::Info targets Unix so this may be acceptable.
	my $info = make_get("file=$TRAV_WINDOWS");
	my $p = $info->params();
	TODO: {
		local $TODO = 'Traversal check is forward-slash only; Windows backslash paths not blocked';
		is($info->status(), $STATUS_FORBIDDEN,
			'Windows-style ..\\..\\..\\path should be blocked with 403');
	}
};

# ---------------------------------------------------------------------------
# Section 7: HTTP_REFERER injection
# Referrer is used to classify robots but also to block spam crawlers.
# ---------------------------------------------------------------------------

subtest 'Referer: closing parenthesis in referer triggers robot classification' => sub {
	# Any referer containing ")" is treated as a spam/robot referrer.
	reset_env();
	$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
	$ENV{REQUEST_METHOD}    = 'GET';
	$ENV{REMOTE_ADDR}       = $REMOTE;
	$ENV{HTTP_USER_AGENT}   = $BENIGN_UA;
	$ENV{HTTP_REFERER}      = 'http://example.com/foo(bar)';

	my $info = CGI::Info->new();
	ok($info->is_robot(), 'referer with ) is classified as robot');
};

subtest 'Referer: backslash normalised before matching (no crash)' => sub {
	# Stray backslashes in the referer are normalised to _ before comparison.
	# Verify this does not produce an exception or regex failure.