CGI-Info
view release on metacpan or search on metacpan
Remove most calls to substr
Added Mediatoolkitbot as a robot
Added NetcraftSurveyAgent as a robot
Added Expanse as a robot
Added Bytespider as a robot
Added t/pod-synopsis.t
Refactored t/unused.t and t/10-compile.t
Fixed Github Actions on Alpine Linux, FreeBSD and OpenBSD
Label AmazonBot as a search engine
Block directory traversal attacks
Set HTTP status to 403 on blocked attacks
Catch another SQL injection attempt
0.74 Wed Jan 4 22:16:12 EST 2023
Added python-requests/2.27.1 as a robot
Use latest Github Actions environment
Support Sec-CH-UA-Mobile
Calling new on an object now returns a clone rather than setting the defaults in the new object
0.73 Fri Oct 29 07:32:37 EDT 2021
Attempt to fix https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541
lib/CGI/Info.pm view on Meta::CPAN
(($has_equals && ($has_quote || $has_semi || $has_dash)) &&
$orig_value =~ /(?:%3D|=)[^-]*+(?:%27|'|--|%3B|;)/i) ||
($has_quote &&
# Detect 'or'-style injection: word + quote + url-encoded or literal 'or' + SQL keyword.
# (?:%6F|o|%4F) = 'o', (?:%72|r|%52) = 'r', both case-folded via /i.
$orig_value =~ /\w*(?:%27|')(?:%6F|o|%4F)(?:%72|r|%52)\s*(?:OR|AND|UNION|SELECT|--)/ix) ||
($has_quote &&
$orig_value =~ /(?:%27|')union/ix)) {
$self->status(403);
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$key=$orig_value'");
} else {
$self->_warn("SQL injection attempt blocked for '$key=$orig_value'");
}
return;
}
}
my $has_select = index($orig_value, 'SELECT') >= 0 || index($orig_value, 'select') >= 0;
my $has_dump = index($orig_value, 'var_dump') >= 0;
my $has_exec = index($orig_value, 'exec') >= 0;
my $has_or = index($orig_value, ' OR ') >= 0;
my $has_and = index($orig_value, ' AND ') >= 0;
lib/CGI/Info.pm view on Meta::CPAN
# Numeric tautology without quotes: OR 1=1, OR 2=2, etc.
($has_or && $orig_value =~ /\bOR\s+\d+\s*=\s*\d+/i) ||
# Bounded lazy .{1,500}? avoids backtracking on "OR aaaa..." with no AND.
($has_or && $has_and && $orig_value =~ /\sOR\s.{1,500}?\sAND\s/) ||
($has_slash && $orig_value =~ /\/\*\*\/ORDER\/\*\*\/BY\/\*\*/ix) ||
($has_dump && $orig_value =~ /var_dump[^m]*+md5/) ||
($has_slash && $has_select && $orig_value =~ /\/AND\/[^(]*+\(SELECT\//) ||
($has_exec && $orig_value =~ /exec[\s+]++[sx]p\w+/ix)) {
$self->status(403);
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$key=$orig_value'");
} else {
$self->_warn("SQL injection attempt blocked for '$key=$orig_value'");
}
return;
}
if(my $agent = $ENV{'HTTP_USER_AGENT'}) {
# Bounded lazy .{1,500}? separates SQL keyword pairs without catastrophic backtracking.
# Possessive .++ would consume the trailing anchor — never match. Unbounded .+ risks ReDoS.
if(($agent =~ /\bSELECT\b.{1,500}?\bAND\b/i) || ($agent =~ /\bORDER\s+BY\b/i) || ($agent =~ /\bOR\s+NOT\b/i) || ($agent =~ /\bAND\b\s+\d+=\d+/) || ($agent =~ /\bTHEN\b.{1,300}?\bELSE\b.{1,300}?\bEND\b/i) || ($agent =~ /\bAND\b.{1,500}?\bSELECT\b/i...
$self->status(403);
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$agent'");
} else {
$self->_warn("SQL injection attempt blocked for '$agent'");
}
return;
}
}
# XSS detection using [^>]+ instead of .+ or .++ :
# - [^>]+ stops naturally at '>' — no backtracking, no ReDoS.
# - [^>] also matches '\n', so multi-line payloads like
# "<img\nsrc=x\nonerror=alert(1)>" are caught without /s.
# - Replaces both the old [^\n]+ (stopped at newline — bypass)
# and the broken .++ (possessive consumed '>' — never matched).
if(($value =~ /(?:%3C|<)(?:%2F|\/)*[a-z0-9%]+(?:%3E|>)/ix) ||
($value =~ /(?:%3C|<)[^>]+(?:%3E|>)/i) ||
($orig_value =~ /(?:%3C|<)(?:%2F|\/)*[a-z0-9%]+(?:%3E|>)/ix) ||
($orig_value =~ /(?:%3C|<)[^>]+(?:%3E|>)/i)) {
$self->status(403);
$self->_warn("XSS injection attempt blocked for '$value'");
return;
}
# Block javascript: URI scheme — no angle brackets, but still executes
# script when used in href or src attributes.
if($orig_value =~ /\bjavascript\s*:/i) {
$self->status(403);
$self->_warn("XSS injection attempt blocked for '$value'");
return;
}
if($value =~ /mustleak\.com\//) {
$self->status(403);
$self->_warn("Blocked mustleak attack for '$key'");
return;
}
if($value =~ /\.\.\//) {
$self->status(403);
$self->_warn("Blocked directory traversal attack for '$key'");
return;
}
}
if(length($value) > 0) {
# Don't add if it's already there
if($FORM{$key} && ($FORM{$key} ne $value)) {
$FORM{$key} .= ",$value";
} else {
$FORM{$key} = $value;
}
lib/CGI/Info.pm view on Meta::CPAN
if(($agent =~ /\bSELECT\b.{1,500}?\bAND\b/i) ||
($agent =~ /\bORDER\s+BY\b/i) ||
($agent =~ /\bOR\s+NOT\b/i) ||
($agent =~ /\bAND\b\s+\d+=\d+/) ||
($agent =~ /\bTHEN\b.{1,300}?\bELSE\b.{1,300}?\bEND\b/i) ||
($agent =~ /\bAND\b.{1,500}?\bSELECT\b/i) ||
($agent =~ /\sAND\s.{1,500}?\sAND\s/)) {
$self->status(403);
$self->{is_robot} = 1;
if($ENV{'REMOTE_ADDR'}) {
$self->_warn($ENV{'REMOTE_ADDR'} . ": SQL injection attempt blocked for '$agent'");
} else {
$self->_warn("SQL injection attempt blocked for '$agent'");
}
return 1;
}
# is_ai implies is_robot: check AI crawlers before the generic bot regex so
# that UAs like ChatGPT-User or Google-Extended (no "bot"/"spider" token)
# are still caught here.
if($self->is_ai()) {
return $self->{is_robot} = 1;
}
lib/CGI/Info.pm view on Meta::CPAN
return $self->{is_robot} = ($type eq 'robot');
}
}
if(my $referrer = $ENV{'HTTP_REFERER'}) {
# $CRAWLER_REFERER_RE is compiled once at module load (see top of file):
# replaces List::Util::any { /^\Q$_\E/i } @crawler_lists (29 per-call
# regex compilations + array allocation eliminated).
$referrer =~ s/\\/_/g;
if(($referrer =~ /\)/) || ($referrer =~ $CRAWLER_REFERER_RE)) {
$self->_debug("is_robot: blocked trawler $referrer");
if($self->{cache}) {
$self->{cache}->set($key, 'robot', $CACHE_TTL_ROBOT);
}
$self->{is_robot} = 1;
return 1;
}
}
# Don't use HTTP_USER_AGENT to detect more than we really have to since
# that is easily spoofed
t/30-basics.t view on Meta::CPAN
subtest 'should block SQL injection attempts' => sub {
mock_env({
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'id=1%27%20OR%201=1--'
}, sub {
my $info = CGI::Info->new(allow => { id => qr/^\d+$/ });
my $params = $info->params();
is $info->status, 422, 'Status 422 on SQL injection';
ok !defined $params->{id}, 'Blocked malicious parameter';
});
};
subtest 'should handle multipart form uploads' => sub {
mock_env({
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'multipart/form-data; boundary=----boundary',
CONTENT_LENGTH => 1000
}, sub {
t/40-more.t view on Meta::CPAN
subtest 'SQL injection detection' => sub {
setup_mock_env(
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => "search=' OR 1=1--"
);
my $info = new_ok('CGI::Info');
my $params = $info->params();
is($info->{status}, 403, 'SQL injection blocked with 403 status');
ok(!defined($params), 'No parameters returned for SQL injection');
restore_env();
};
# Test XSS injection detection
subtest 'XSS injection detection' => sub {
setup_mock_env(
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'comment=<script>alert("xss")</script>'
);
# Mock STDIN data so that we don't hang on reading
$CGI::Info::stdin_data = 'username=test&password=secret';
my $info = CGI::Info->new();
my $params = $info->params();
is($info->{status}, 403, 'XSS injection blocked');
ok(!defined($params), 'No parameters returned for XSS injection');
restore_env();
$CGI::Info::stdin_data = undef;
};
# Test directory traversal detection
subtest 'Directory traversal detection' => sub {
setup_mock_env(
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'file=../../../etc/passwd'
);
my $info = CGI::Info->new();
my $params = $info->params();
is($info->{status}, 403, 'Directory traversal blocked');
ok(!defined($params), 'No parameters returned for directory traversal');
restore_env();
};
# Test User-Agent SQL injection detection
subtest 'User-Agent SQL injection detection' => sub {
setup_mock_env(
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'q=test',
HTTP_USER_AGENT => "Mozilla' AND 1=1 ORDER BY 1--"
);
my $info = CGI::Info->new();
my $params = $info->params();
is($info->{status}, 403, 'User-Agent SQL injection blocked');
ok(!defined($params), 'No parameters returned for malicious User-Agent');
restore_env();
};
# Test file upload validation
subtest 'File upload validation' => sub {
my $temp_dir = tempdir(CLEANUP => 1);
setup_mock_env(
t/cgi_security.t view on Meta::CPAN
#
# GATEWAY_INTERFACE = 'CGI/1.1'
# REQUEST_METHOD = 'GET' | 'POST'
# REMOTE_ADDR = IPv4 string
# HTTP_USER_AGENT = arbitrary string (attacker-controlled)
# QUERY_STRING = key=value pairs (attacker-controlled)
# HTTP_COOKIE = cookie header (attacker-controlled)
#
# =head4 OUTPUT (expected secure behaviour)
#
# params() returns undef AND status() == 403 on blocked injection
# params() returns undef AND status() == 405 on disallowed HTTP method
# is_robot() returns 1 AND status() == 403 on UA SQL injection
#
# =head1 FORMAL SPECIFICATION (Z calculus)
#
# WAF ≠λreq • (injectionPattern? req) → (status 403, params ∅)
# | (¬injectionPattern? req) → params ≠∅
#
# SafeParam ≠{ v : String | ¬∃p ∈ InjectPatterns • p ∈ v }
#
# Invariant: ∀ req • is_blocked(req) ↔ status(req) = 403
use strict;
use warnings;
use Test::Most;
use Test::Mockingbird;
use Readonly;
BEGIN { use_ok('CGI::Info') or BAIL_OUT('CGI::Info failed to load') }
t/cgi_security.t view on Meta::CPAN
# reset() in reset_env() clears it, so setting it here is safe.
$CGI::Info::stdin_data = $body;
return CGI::Info->new();
}
# ---------------------------------------------------------------------------
# Section 1: SQL injection via GET query string — quote-based patterns
# These patterns ARE caught by the current WAF.
# ---------------------------------------------------------------------------
subtest 'SQL: classic single-quote OR bypass blocked in GET' => sub {
# Pattern: ' OR '1'='1 — the WAF's quote regex should catch this.
my $info = make_get("q=$SQL_CLASSIC_QUOTE");
my $p = $info->params();
is($info->status(), $STATUS_FORBIDDEN,
"classic ' OR '1'='1 triggers status 403");
ok(!defined $p, 'params() returns undef after blocked injection');
};
subtest "SQL: admin'-- comment bypass blocked in GET" => sub {
# Pattern: admin'-- — trailing comment collapses the WHERE clause.
my $info = make_get("user=$SQL_COMMENT_BYPASS");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
"admin'-- comment bypass triggers status 403");
};
subtest 'SQL: exec xp_cmdshell blocked in GET' => sub {
# Extended stored procedure call — caught by the exec regex.
my $info = make_get("id=$SQL_EXEC_XP");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'exec xp_cmdshell triggers status 403');
};
subtest 'SQL: exec sp_executesql blocked in GET' => sub {
my $info = make_get("id=$SQL_EXEC_SP");
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'exec sp_executesql triggers status 403');
};
# ---------------------------------------------------------------------------
# Section 2: SQL injection bypass — patterns the WAF does NOT currently catch
#
# These tests document real bypass vectors. They WILL FAIL against the
# current code because the WAF is missing these checks. Use the failures
# to drive fixes.
# ---------------------------------------------------------------------------
subtest 'SQL: OR 1=1 without quotes blocked in GET' => sub {
# Fixed: the WAF now includes a numeric-tautology check
# /\bOR\s+\d+\s*=\s*\d+/i that fires without requiring quotes or AND.
my $info = make_get("q=$SQL_TAUTOLOGY_NOQUOTE");
my $p = $info->params();
is($info->status(), $STATUS_FORBIDDEN,
'OR 1=1 (no quotes) is blocked with 403');
ok(!defined $p, 'params() returns undef for OR tautology');
};
subtest 'SQL: UNION SELECT without quotes blocked in GET' => sub {
# Fixed: regex was /select[[a-z]\s\*]from/ix — malformed char class [[a-z]
# consumed the ] early so the pattern never matched real SQL.
# Now uses /\bselect\b.+\bfrom\b/is which matches any SELECT…FROM form.
my $info = make_get("id=$SQL_UNION_NOQUOTE");
my $p = $info->params();
is($info->status(), $STATUS_FORBIDDEN,
'UNION SELECT ... FROM is blocked with 403');
ok(!defined $p, 'params() returns undef for UNION SELECT');
};
subtest 'SQL: SELECT * FROM blocked in GET' => sub {
# Fixed: /\bselect\b.+\bfrom\b/is now correctly matches SELECT * FROM.
my $info = make_get("tbl=$SQL_SELECT_STAR");
my $p = $info->params();
is($info->status(), $STATUS_FORBIDDEN,
'SELECT * FROM is blocked with 403');
};
subtest 'SQL BYPASS: stacked query ; DROP TABLE not blocked in GET [BUG]' => sub {
# Stacked query uses semicolons, not quotes. $has_semi is computed but
# never used to block; it only participates in the equals+quote+semi gate.
my $info = make_get("id=$SQL_STACKED");
my $p = $info->params();
TODO: {
local $TODO = 'WAF does not block standalone stacked queries with ;';
is($info->status(), $STATUS_FORBIDDEN,
'stacked ; DROP TABLE should be blocked with 403');
}
};
# ---------------------------------------------------------------------------
# Section 3: SQL injection via POST — entire WAF block is skipped
# The WAF is gated on REQUEST_METHOD eq 'GET'; POST body is never inspected.
# These tests document the architectural decision. Flag for review.
# ---------------------------------------------------------------------------
subtest 'SQL POST: classic injection blocked in POST body' => sub {
# Fixed: WAF now inspects both GET and POST. The GET-only gate
# (REQUEST_METHOD eq 'GET') has been removed.
my $body = "user=$SQL_CLASSIC_QUOTE";
my $info = make_post($body);
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'POST SQL injection is blocked with 403');
};
subtest 'SQL POST: UNION SELECT blocked in POST body' => sub {
my $body = "id=$SQL_UNION_NOQUOTE";
my $info = make_post($body);
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'POST UNION SELECT is blocked with 403');
};
# ---------------------------------------------------------------------------
# Section 4: SQL injection via User-Agent header
# is_robot() runs a UA-level SQL check; params() repeats it inside the GET gate.
# ---------------------------------------------------------------------------
subtest 'SQL UA: SELECT AND in User-Agent blocked by is_robot()' => sub {
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.
t/cgi_security.t view on Meta::CPAN
# Section 10: mustleak.com and other WAF-specific blocklist patterns
# ---------------------------------------------------------------------------
subtest 'WAF blocklist: mustleak.com in value triggers 403' => sub {
my $info = make_get('u=http://mustleak.com/steal');
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'mustleak.com in param value triggers 403');
};
subtest 'WAF blocklist: mustleak.com subdomain also blocked' => sub {
my $info = make_get('u=http://data.mustleak.com/exfil');
$info->params();
is($info->status(), $STATUS_FORBIDDEN,
'mustleak.com subdomain in param value triggers 403');
};
# ---------------------------------------------------------------------------
# Section 11: Global variable integrity under hostile input
# Verify $_ is not clobbered by any CGI::Info method.
# ---------------------------------------------------------------------------
t/cgi_security.t view on Meta::CPAN
$ENV{HTTP_SEC_CH_UA_MOBILE} = "?1\r\nSet-Cookie: admin=1";
ok(!CGI::Info->new()->is_mobile(),
'CRLF-bearing Sec-CH-UA-Mobile header does not trigger is_mobile');
};
# ---------------------------------------------------------------------------
# Section 14: Benign inputs must not be false-positived by the WAF
# Confirm the WAF does not break legitimate use-cases.
# ---------------------------------------------------------------------------
subtest 'WAF: safe alphanumeric params not blocked' => sub {
my $info = make_get('name=Alice&age=30&city=Nowhere');
my $p = $info->params();
ok(defined $p, 'safe params return a hashref');
is($p->{name}, 'Alice', 'name param preserved');
is($p->{age}, '30', 'age param preserved');
isnt($info->status(), $STATUS_FORBIDDEN, 'safe request is not a 403');
};
subtest 'WAF: URL with double-dash in FBCLID param not false-positived' => sub {
# FBCLID values legitimately contain "--" (Facebook click ID).
t/edge_cases.t view on Meta::CPAN
subtest 'WAF: deeply nested HTML not treated as XSS (no angle brackets)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'desc=bold+and+italic+text';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on HTML-like words without brackets');
ok($info->status() != 403, 'not blocked as XSS without angle brackets');
};
subtest 'WAF: FBCLID with double-dash (mentioned in source comment)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'fbclid=AQHk--sometoken123';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on FBCLID with double-dash');
# Facebook FBCLID with "--" should not be blocked per source comment
ok($info->status() != 403, 'FBCLID with -- not blocked as SQL injection');
};
subtest 'WAF: multiline value (CR/LF injection)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'hdr=value%0D%0AX-Injected%3A+evil';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
t/edge_cases.t view on Meta::CPAN
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# Long SQL injection padded with junk
my $payload = "id=" . ('A' x 1000) . "'%20OR%201=1--";
$ENV{QUERY_STRING} = $payload;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on long SQL injection attempt');
is($info->status(), 403, 'long SQL injection blocked with 403');
};
# ============================================================
# 4. Pathological HTTP environment variables
# ============================================================
subtest 'env: HTTP_HOST with port number' => sub {
reset_env();
$ENV{HTTP_HOST} = 'example.com:8080';
my $info = CGI::Info->new();
t/edge_cases.t view on Meta::CPAN
subtest 'boundary: max_upload_size = 0 blocks everything' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 1;
my $info = CGI::Info->new(max_upload_size => 0);
my $p = eval { $info->params() };
ok(!$@, 'does not die with max_upload_size=0');
is($info->status(), 413, 'any POST body blocked when max_upload_size=0');
};
subtest 'boundary: max_upload_size = -1 means no limit' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_LENGTH} = 999_999_999;
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
$CGI::Info::stdin_data = 'x=1';
t/edge_cases.t view on Meta::CPAN
ok($info->is_ai(), 'IS_AI=1 override: is_ai true for non-AI UA');
ok($info->is_robot(), 'IS_AI=1 override: is_robot true via is_ai delegation inside is_robot');
};
# ============================================================
# 19. WAF: additional attack patterns verified
# ============================================================
# The path-traversal guard checks the sanitised $value for `../`.
# Every legitimate URL path would use encoded %2E%2E%2F or absolute refs.
subtest 'WAF: ../ path traversal in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'file=../../etc/passwd';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on path traversal attempt');
is($info->status(), 403, 'path traversal (../) in GET value blocked with 403');
};
# The mustleak.com guard is a hard-coded canary domain used in SSRF probes.
subtest 'WAF: mustleak.com/ in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'url=http://mustleak.com/probe.js';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on mustleak.com probe URL');
is($info->status(), 403, 'mustleak.com/ in value blocked with 403');
};
# XSS angle-bracket injection: checked on both $value (post-sanitise) and
# $orig_value (pre-sanitise) so HTML-encoding evasion is also caught.
subtest 'WAF: XSS <script> tag in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'search=<script>alert(1)</script>';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on XSS script injection');
is($info->status(), 403, 'XSS <script> tag blocked with 403');
};
# Encoded XSS: %3Cscript%3E should also be caught (orig_value is checked).
subtest 'WAF: URL-encoded XSS %3Cscript%3E in GET value blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'q=%3Cscript%3Ealert%281%29%3C%2Fscript%3E';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on URL-encoded XSS');
is($info->status(), 403, 'URL-encoded XSS blocked with 403');
};
# SQL injection via exec(xp_cmdshell) pattern — a classic MSSQL shell-escape.
# The WAF checks for exec followed by sp/xp stored procedure prefixes.
subtest 'WAF: exec xp_cmdshell stored-procedure injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# + is decoded to space: value becomes "exec xp_cmdshell"
$ENV{QUERY_STRING} = 'cmd=exec+xp_cmdshell';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on exec xp_cmdshell injection');
is($info->status(), 403, 'exec xp_cmdshell blocked with 403');
};
# SQL injection via exec(sp_executesql) — same pattern with sp_ prefix.
subtest 'WAF: exec sp_executesql stored-procedure injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'cmd=exec+sp_executesql';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on exec sp_executesql injection');
is($info->status(), 403, 'exec sp_executesql blocked with 403');
};
# Tautology injection AND 1=1: a minimal always-true condition.
subtest 'WAF: AND 1=1 tautology injection blocked (403)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
# + decoded to space: "5 AND 1=1"
$ENV{QUERY_STRING} = 'id=5+AND+1%3D1';
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on AND 1=1 injection');
is($info->status(), 403, 'AND 1=1 tautology injection blocked with 403');
};
# The WAF now inspects both GET and POST. The previous GET-only gate
# was a security gap; it has been removed. This test verifies that
# known-hostile payloads in POST bodies are also blocked with 403.
subtest 'WAF: SQL injection in POST body IS blocked (WAF now covers POST)' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'POST';
$ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
my $body = "id=1'+OR+1%3D1--";
$ENV{CONTENT_LENGTH} = length($body);
$CGI::Info::stdin_data = $body;
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'does not die on SQL injection in POST body');
is($info->status(), 403,
'POST body SQL injection is now blocked with 403');
};
# ============================================================
# 20. HTTP method boundary: OPTIONS and DELETE
# ============================================================
subtest 'HTTP OPTIONS returns 405 Method Not Allowed' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'OPTIONS';
t/edge_cases.t view on Meta::CPAN
my $info = CGI::Info->new();
my $p = eval { $info->params() };
ok(!$@, 'params() does not die when called with a dirty $@');
};
# ============================================================
# 25. Referrer-based robot detection: hostile referrer values
# ============================================================
# Spam referrers with a closing parenthesis are blocked.
# The WAF checks for ')' in the referrer string.
subtest 'is_robot: referrer with closing parenthesis blocked as spam' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0';
$ENV{REMOTE_ADDR} = '1.2.3.4';
$ENV{HTTP_REFERER} = 'http://spam-site.example.com/page(with-paren)';
my $info = CGI::Info->new();
ok($info->is_robot(), 'referrer with ) detected as robot/spam');
};
# A referrer that backslash-abuses the URL must be normalised before
t/edge_cases.t view on Meta::CPAN
$ENV{REMOTE_ADDR} = '1.2.3.4';
# Backslash variant of a known spam referrer — should be normalised to _ not crash
$ENV{HTTP_REFERER} = 'http://semalt.com\\hack';
my $info = new_ok('CGI::Info');
eval { $info->is_robot() };
ok(!$@, 'backslash in referrer does not cause is_robot() to die');
};
# A known spam referrer from the embedded blocklist must be flagged.
subtest 'is_robot: known spam referrer (semalt.com) blocked' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 Firefox/120.0';
$ENV{REMOTE_ADDR} = '1.2.3.4';
$ENV{HTTP_REFERER} = 'http://semalt.com/fake-traffic';
my $info = CGI::Info->new();
ok($info->is_robot(), 'semalt.com in HTTP_REFERER flagged as robot');
};
# ============================================================
t/extended_tests.t view on Meta::CPAN
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'score=999';
my $info = CGI::Info->new();
my $p = $info->params(allow => {
score => { type => 'integer', min => 0, max => 100 }
});
ok(!defined($p) || !defined($p->{score}),
'out-of-range value blocked by Params::Validate::Strict schema');
is($info->status(), 422, 'schema block sets status 422');
};
# ============================================================
# 15. param() — in_param recursion guard
# Branch: $self->{in_param} && $self->{allow} => delete allow temporarily
# A coderef allow that calls $obj->param() on the same instance
# ============================================================
subtest 'param: recursion guard prevents deep recursion in coderef validator' => sub {
t/extended_tests.t view on Meta::CPAN
}
$ENV{HTTP_USER_AGENT} = 'DesktopBrowser/1.0';
$ENV{REMOTE_ADDR} = '5.6.7.8';
my $info = CGI::Info->new(cache => DesktopCache->new());
ok(!$info->is_mobile(), 'cache hit for non-mobile type returns false');
};
# ============================================================
# 19. is_robot() — HTTP_REFERER with closing paren => blocked trawler
# Branch: $referrer =~ /\)/
# ============================================================
subtest 'is_robot: HTTP_REFERER with closing paren triggers trawler block' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (compatible)';
$ENV{REMOTE_ADDR} = '1.2.3.4';
$ENV{HTTP_REFERER} = 'http://evil.example.com/page)';
my $info = CGI::Info->new();
t/function.t view on Meta::CPAN
# allow regex mismatch removes value and sets 422
subtest 'params() - allow regex mismatch blocks value and sets 422' => sub {
plan tests => 2;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'id=abc';
my $info = CGI::Info->new();
my $p = $info->params(allow => { id => qr/^\d+$/ });
ok(!defined $p, 'regex-blocked parameter excluded from result');
is($info->status(), $config{status_unproc}, 'status 422 set on validation failure');
};
# allow exact-string comparison
subtest 'params() - allow exact-string match passes valid value' => sub {
plan tests => 1;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'color=blue';
t/function.t view on Meta::CPAN
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'num=4&num2=3';
my $info = CGI::Info->new();
my $p = $info->params(allow => {
num => sub { ($_[1] % 2) == 0 }, # even => accept
num2 => sub { ($_[1] % 2) == 0 }, # odd => reject
});
ok(defined $p->{num}, 'even number passes coderef validator');
ok(!defined $p->{num2}, 'odd number blocked by coderef validator');
};
# SQL injection in query string must be blocked with 403
subtest 'params() - SQL injection blocked with 403' => sub {
plan tests => 2;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = "id=1'%20OR%201=1";
my $info = CGI::Info->new();
my $p = $info->params();
ok(!defined $p, 'SQL injection blocked');
is($info->status(), $config{status_forbidden}, 'status 403 set on SQL injection');
};
# XSS in query string must be blocked with 403
subtest 'params() - XSS injection blocked with 403' => sub {
plan tests => 2;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'q=%3Cscript%3Ealert(1)%3C%2Fscript%3E';
my $info = CGI::Info->new();
my $p = $info->params();
ok(!defined $p, 'XSS injection blocked');
is($info->status(), $config{status_forbidden}, 'status 403 set on XSS');
};
# Directory traversal must be blocked with 403
subtest 'params() - directory traversal blocked with 403' => sub {
plan tests => 2;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'file=../../etc/passwd';
my $info = CGI::Info->new();
my $p = $info->params();
ok(!defined $p, 'directory traversal blocked');
is($info->status(), $config{status_forbidden}, 'status 403 set on traversal');
};
# mustleak probe must be blocked with 403
subtest 'params() - mustleak probe blocked with 403' => sub {
plan tests => 2;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'x=mustleak.com/probe';
my $info = CGI::Info->new();
my $p = $info->params();
ok(!defined $p, 'mustleak probe blocked');
is($info->status(), $config{status_forbidden}, 'status 403 set on mustleak');
};
# Duplicate keys should be comma-joined
subtest 'params() - duplicate keys comma-joined' => sub {
plan tests => 1;
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'color=red&color=blue';
t/integration.t view on Meta::CPAN
$ENV{HTTP_USER_AGENT} = 'Mozilla/5.0 (iPad; CPU OS 15_0 like Mac OS X)';
$ENV{REMOTE_ADDR} = '1.2.3.4';
my $info = CGI::Info->new();
ok($info->is_tablet(), 'is_tablet() true for iPad');
ok($info->is_mobile(), 'is_mobile() true for iPad (tablets are mobile)');
is($info->browser_type(), 'mobile', 'browser_type() mobile for tablet');
};
subtest 'robot browser: is_robot, browser_type, params blocked on SQL UA' => sub {
reset_env();
$ENV{HTTP_USER_AGENT} = 'ClaudeBot/1.0 (+http://www.anthropic.com)';
$ENV{REMOTE_ADDR} = '1.2.3.4';
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'q=test';
my $info = CGI::Info->new();
ok($info->is_robot(), 'is_robot() true for ClaudeBot');
t/integration.t view on Meta::CPAN
my $info = CGI::Info->new();
$info->logdir($tmp);
is($info->logdir(), $tmp, 'logdir() returns previously set directory');
};
# ============================================================
# 15. WAF: multiple attack types in sequence, each gets correct status
# ============================================================
subtest 'WAF: SQL injection blocked with 403' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = "id=1'%20OR%201=1";
my $info = CGI::Info->new();
ok(!defined $info->params(), 'SQL injection returns undef');
is($info->status(), 403, 'SQL injection status 403');
ok(defined $info->messages(), 'SQL injection logged to messages');
};
subtest 'WAF: XSS injection blocked with 403' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'q=%3Cscript%3Ealert(1)%3C%2Fscript%3E';
my $info = CGI::Info->new();
ok(!defined $info->params(), 'XSS returns undef');
is($info->status(), 403, 'XSS status 403');
};
subtest 'WAF: directory traversal blocked with 403' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'file=../../etc/shadow';
my $info = CGI::Info->new();
ok(!defined $info->params(), 'traversal returns undef');
is($info->status(), 403, 'traversal status 403');
};
subtest 'WAF: mustleak blocked with 403' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'probe=mustleak.com/test';
my $info = CGI::Info->new();
ok(!defined $info->params(), 'mustleak returns undef');
is($info->status(), 403, 'mustleak status 403');
};
t/is_robot.t view on Meta::CPAN
]);
$i->cache($cache);
$i->set_logger(MyLogger->new());
ok($i->is_robot() == 1);
cmp_ok($i->status(), '==', 200, 'Default HTTP status is 200');
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/5.0 (Windows; U; Windows NT 5.1; zh) AppleWebKit/522.11.3 (KHTML, like Gecko) Version/3.0 Safari/522.11.3\") OR EXTRACTVALUE(2534,CONCAT(0x5c,0x7170767871,(SELECT (ELT(2534=2534,1))),0x716b627171)) AND (\"OqXr\"=\"...
delete $ENV{'HTTP_REFERER'};
$i = new_ok('CGI::Info');
ok($i->is_robot());
cmp_ok($i->status(), '==', 403, 'Check HTTP_USER_AGENT SQL Injection is blocked');
}
# ok($i->as_string() eq 'foo=<\;script>\;alert(hello)<\;/script>\;');
ok(!defined($i->param('foo')));
ok($i->as_string() eq '');
$ENV{'QUERY_STRING'} = 'foo=&fred=wilma&foo=bar';
$i = new_ok('CGI::Info');
ok($i->param('foo', logger => MyLogger->new()) eq 'bar');
ok($i->param('fred') eq 'wilma');
ok($i->as_string() eq 'foo=bar; fred=wilma');
subtest 'SQL injection is blocked' => sub {
# Preserve the current %ENV, so changes are local to this subtest
local %ENV = %ENV;
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'QUERY_STRING'} = 'nan=lost&redir=-8717%22%20OR%208224%3D6013--%20ETLn';
my $info = new_ok('CGI::Info');
ok(!defined($info->param('nan')));
ok(!defined($info->param('redir')));
};
@ARGV = ('foo=bar', 'fred=wilma' );
$i = new_ok('CGI::Info');
%p = %{$i->params(logger => MyLogger->new())};
ok($p{fred} eq 'wilma');
ok($i->as_string() eq 'foo=bar; fred=wilma');
ok(!$i->is_mobile());
@ARGV= ('file=/../../../../etc/passwd%00');
$i = new_ok('CGI::Info');
dies_ok { %p = %{$i->params()} }; # Warns because logger isn't set
like($@, qr/Blocked directory traversal attack/);
diag(Data::Dumper->new([$i->messages()])->Dump()) if($ENV{'TEST_VERBOSE'});
like(
$i->messages()->[1]->{'message'},
qr/^Blocked directory traversal attack for 'file'/,
'Warning generated for disallowed parameter'
);
cmp_ok($i->messages()->[1]->{'level'}, 'eq', 'warn');
like($i->messages_as_string(), qr/Blocked directory traversal attack/, 'messages_as_string works');
@ARGV= ('file=/etc/passwd%00');
$i = new_ok('CGI::Info');
lives_ok { %p = %{$i->params()}; };
like($p{'file'}, qr/passwd$/, 'strip NUL byte poison');
@ARGV = ('--mobile', 'foo=bar', 'fred=wilma' );
$i = new_ok('CGI::Info');
%p = %{$i->params()};
ok($p{fred} eq 'wilma');
package MockLogger;
sub new { bless { }, shift }
sub trace { }
sub debug { }
sub warn { shift; $mess = (ref($_[0]) eq 'ARRAY') ? join(' ', @{$_[0]}) : join(' ' , @_) }
}
my $info = new_ok('CGI::Info');
my $params = $info->params(logger => MockLogger->new());
like($mess, qr/SQL injection attempt blocked/, 'Correct message when blocking SQL injection');
cmp_ok($info->status(), '==', 403, 'SQL injection causes HTTP code 403');
}
$ENV{'QUERY_STRING'} = 'country=/etc/passwd&page=by_location';
$i = new_ok('CGI::Info');
my $allow = {
'entry' => undef,
'country' => qr/^[A-Z\s]+$/i, # Must start with a letter
subtest 'params() - allow: Params::Validate::Strict schema blocks invalid' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'age=999';
my $info = CGI::Info->new();
my $p = $info->params(allow => {
age => { type => 'integer', min => 0, max => 150 }
});
ok(!defined($p) || !defined($p->{age}),
'out-of-range value blocked by schema');
};
subtest 'params() - blocks SQL injection, returns undef, status 403' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = "id=1'%20OR%201=1";
my $info = CGI::Info->new();
ok(!defined $info->params(), 'SQL injection attempt returns undef');
is($info->status(), 403, 'status 403 on SQL injection');
my $upload_dir = tempdir(CLEANUP => 1);
subtest 'SQL Injection Detection' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'username=nigel%27+OR+%271%27%3D%271',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined($params), 'SQL injection attempt blocked');
is($info->status(), 403, 'Status set to 403 Forbidden');
$ENV{'QUERY_STRING'} = 'page=by_location&county=CA&country=United%2F%2A%2A%2FStates%29%2F%2A%2A%2FAND%2F%2A%2A%2F%28SELECT%2F%2A%2A%2F6734%2F%2A%2A%2FFROM%2F%2A%2A%2F%28SELECT%28SLEEP%285%29%29%29lRNi%29%2F%2A%2A%2FAND%2F%2A%2A%2F%288984%3D8984';
$info = new_ok('CGI::Info');
$params = $info->params();
ok(!defined $params, 'SQL injection attempt blocked 2');
is($info->status(), 403, 'Status set to 403 Forbidden');
};
subtest 'XSS Sanitization' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'comment=<script>alert("xss")</script>',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'XSS injection attempt blocked');
is($info->status(), 403, 'Status set to 403 Forbidden');
};
subtest 'Directory Traversal Prevention' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'file=../../etc/passwd',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'Directory traversal attempt blocked');
is($info->status(), 403, 'Status set to 403 Forbidden');
};
subtest 'Upload Directory Validation' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'POST',
CONTENT_TYPE => 'multipart/form-data; boundary=12345',
CONTENT_LENGTH => 100,
C_DOCUMENT_ROOT => $upload_dir,
# ============================================================
subtest 'SQL Injection: OR...AND without quotes (vwf.log pattern)' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'entry=-4346%22+OR+1749%3D1749+AND+%22dgiO%22%3D%22dgiO',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'OR...AND injection without single quotes blocked');
is($info->status(), 403, 'Status 403 on OR...AND injection');
};
subtest 'SQL Injection: AND 1=1' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'id=1%20AND%201%3D1',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'AND 1=1 injection blocked');
is($info->status(), 403, 'Status 403 on AND 1=1');
};
subtest 'SQL Injection: UNION SELECT' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => "id=1%27%20UNION%20SELECT%20username%2Cpassword%20FROM%20users--",
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'UNION SELECT injection blocked');
is($info->status(), 403, 'Status 403 on UNION SELECT');
};
subtest 'SQL Injection: exec stored procedure (xp_)' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'cmd=exec+xp_cmdshell+%27dir%27',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'exec xp_ stored procedure injection blocked');
is($info->status(), 403, 'Status 403 on exec xp_');
};
subtest 'SQL Injection: exec sp_ stored procedure' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'cmd=exec%20sp_executesql%20N%27SELECT+1%27',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'exec sp_ stored procedure injection blocked');
is($info->status(), 403, 'Status 403 on exec sp_');
};
subtest 'SQL Injection: var_dump...md5 probe' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'x=var_dump(md5(12345))',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'var_dump...md5 probe blocked');
is($info->status(), 403, 'Status 403 on var_dump...md5');
};
subtest 'SQL Injection: ORDER BY comment style' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'sort=%2F%2A%2A%2FORDER%2F%2A%2A%2FBY%2F%2A%2A%2F1',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, '/**/ ORDER /**/ BY injection blocked');
is($info->status(), 403, 'Status 403 on comment-style ORDER BY');
};
subtest 'SQL Injection: double-dash comment terminator with equals' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'redir=-8717%22%20OR%208224%3D6013--%20ETLn',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'double-dash comment terminator injection blocked');
is($info->status(), 403, 'Status 403 on -- terminator injection');
};
subtest 'SQL Injection: Stock/SELECT*from pattern' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => "surname=%27Stock%20or%20%281%2C2%29%3D%28SELECT%2afrom%28select%20name_const%28CHAR%28111%29%2C1%29%29a%29%20--%20and%201%3D1%27",
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'SELECT*from injection blocked');
is($info->status(), 403, 'Status 403 on SELECT*from');
};
subtest 'SQL Injection: via User-Agent header' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'x=1',
HTTP_USER_AGENT => 'Mozilla/5.0 SELECT foo AND bar FROM users',
REMOTE_ADDR => '1.2.3.4',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'SQL injection in User-Agent blocked');
is($info->status(), 403, 'Status 403 on SQL injection in User-Agent');
};
subtest 'WAF: mustleak.com probe blocked' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'probe=mustleak.com/test',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'mustleak.com probe blocked');
is($info->status(), 403, 'Status 403 on mustleak probe');
};
subtest 'WAF: XSS via encoded angle brackets' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'x=%3Cscript%3Ealert%281%29%3C%2Fscript%3E',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'URL-encoded XSS blocked');
is($info->status(), 403, 'Status 403 on encoded XSS');
};
subtest 'WAF: XSS via HTML img tag' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'x=%3Cimg+src%3Dx+onerror%3Dalert%281%29%3E',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'img onerror XSS blocked');
is($info->status(), 403, 'Status 403 on img XSS');
};
subtest 'WAF: directory traversal with URL encoding' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'file=..%2F..%2Fetc%2Fpasswd',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(!defined $params, 'URL-encoded directory traversal blocked');
is($info->status(), 403, 'Status 403 on encoded traversal');
};
subtest 'WAF: false positive — FBCLID with double-dash' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'fbclid=AQHk--sometoken123456789',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(defined $params, 'FBCLID with -- not blocked (false positive check)');
ok($params->{fbclid}, 'FBCLID value accessible');
};
subtest 'WAF: false positive — normal alphanumeric values pass' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'name=Alice&age=30&city=New+York&id=12345',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(defined $params, 'clean params not blocked');
is($params->{name}, 'Alice', 'name passed through');
is($params->{age}, '30', 'age passed through');
is($params->{city}, 'New York', 'city with space passed through');
is($params->{id}, '12345', 'numeric id passed through');
is($info->status(), 200, 'status 200 for clean params');
};
subtest 'WAF: false positive — SELECT as part of legitimate word' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'action=SELECT_item&menu=dropdown',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
ok(defined $params, 'SELECT_ prefix not blocked');
is($params->{action}, 'SELECT_item', 'SELECT_ value passed through');
is($info->status(), 200, 'status 200 for benign SELECT_ value');
};
subtest 'WAF: false positive — email address with equals in base64' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'token=abc123def456ghi789%3D%3D',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
# Base64 padding == does not contain injection chars alongside it
ok(defined $params, 'base64-padded token not blocked');
is($info->status(), 200, 'status 200 for base64 token');
};
subtest 'WAF: SQL injection blocked on is_robot() SQL UA' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'x=clean',
HTTP_USER_AGENT => 'bot/1.0 AND 1=1',
REMOTE_ADDR => '1.2.3.4',
);
$info = new_ok('CGI::Info');
ok($info->is_robot(), 'SQL-injecting UA flagged as robot');
is($info->status(), 403, 'Status 403 on SQL injection in UA via is_robot');
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'data=hello%00world',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
if(defined $params && defined $params->{data}) {
unlike($params->{data}, qr/\x00/, 'NUL byte stripped from value');
} else {
pass('params blocked or value empty after NUL strip (acceptable)');
}
};
subtest 'WAF: %00 NUL byte in value stripped' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'data=hello%2500world',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
# %2500 URL-decodes to literal %00 (percent-zero-zero).
# The fix applies the %00 strip a second time after URL-decoding,
# so %2500 -> %00 -> '' and the value becomes 'helloworld'.
if(defined $params && defined $params->{data}) {
unlike($params->{data}, qr/\x00/, 'NUL byte not present after fix');
unlike($params->{data}, qr/%00/, 'literal %00 stripped after URL-decode');
} else {
pass('params blocked or value empty after strip (acceptable)');
}
};
subtest 'WAF: HTML comment injection stripped' => sub {
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => 'note=hello<!--+evil+-->world',
);
$info = new_ok('CGI::Info');
my $params = $info->params();
if(defined $params && defined $params->{note}) {
unlike($params->{note}, qr/<!--/, 'HTML comment open stripped');
unlike($params->{note}, qr/-->/, 'HTML comment close stripped');
} else {
pass('params blocked or stripped (acceptable)');
}
};
subtest 'WAF: clean request after attack does not persist 403 status' => sub {
# First request: attack
local %ENV = (
GATEWAY_INTERFACE => 'CGI/1.1',
REQUEST_METHOD => 'GET',
QUERY_STRING => "x=1'%20OR%201=1",
);
( run in 2.062 seconds using v1.01-cache-2.11-cpan-c221a9de4ec )