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
if($has_quote || $has_hash || ($has_equals && $has_dash)) {
if(($orig_value =~ /(\%27)|(\')|(\%23)|(\#)/ix) ||
(($has_equals && ($has_quote || $has_semi || $has_dash)) &&
$orig_value =~ /((\%3D)|(=))[^-]*+((\%27)|(\')|(\-\-)|(\%3B)|(;))/i) ||
($has_quote &&
$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
if(($has_select && $orig_value =~ /select[[a-z]\s\*]from/ix) ||
($has_and && $orig_value =~ /\sAND\s1=1/ix) ||
($has_or && $has_and && $orig_value =~ /\sOR\s.*\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|\+)++(s|x)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'}) {
if(($agent =~ /SELECT.+AND.+/) || ($agent =~ /ORDER BY /) || ($agent =~ / OR NOT /) || ($agent =~ / AND \d+=\d+/) || ($agent =~ /THEN.+ELSE.+END/) || ($agent =~ /.+AND.+SELECT.+/) || ($agent =~ /\sAND\s.+\sAND\s/)) {
$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;
}
}
if(($value =~ /((\%3C)|<)((\%2F)|\/)*[a-z0-9\%]+((\%3E)|>)/ix) ||
($value =~ /((\%3C)|<)[^\n]+((\%3E)|>)/i) ||
($orig_value =~ /((\%3C)|<)((\%2F)|\/)*[a-z0-9\%]+((\%3E)|>)/ix) ||
($orig_value =~ /((\%3C)|<)[^\n]+((\%3E)|>)/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
unless($remote && $agent) {
# Probably not running in CGI - assume real person
return 0;
}
# See also params()
if(($agent =~ /SELECT.+AND.+/) || ($agent =~ /ORDER BY /) || ($agent =~ / OR NOT /) || ($agent =~ / AND \d+=\d+/) || ($agent =~ /THEN.+ELSE.+END/) || ($agent =~ /.+AND.+SELECT.+/) || ($agent =~ /\sAND\s.+\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;
}
if($agent =~ /.+bot|axios\/1\.6\.7|bidswitchbot|bytespider|ClaudeBot|Clickagy.Intelligence.Bot|msnptc|CriteoBot|is_archiver|backstreet|fuzz faster|linkfluence\.com|spider|scoutjet|gingersoftware|heritrix|dodnetdotcom|yandex|nutch|ezooms|plukkie|nova...
$self->{is_robot} = 1;
return 1;
}
# TODO:
# Download and use list from
lib/CGI/Info.pm view on Meta::CPAN
'http://7makemoneyonline.com',
'http://anticrawler.org',
'http://baixar-musicas-gratis.com',
'http://descargar-musica-gratis.net',
# Mine
'http://www.seokicks.de/robot.html',
);
$referrer =~ s/\\/_/g;
if(($referrer =~ /\)/) || (List::Util::any { $_ =~ /^$referrer/ } @crawler_lists)) {
$self->_debug("is_robot: blocked trawler $referrer");
if($self->{cache}) {
$self->{cache}->set($key, 'robot', '1 day');
}
$self->{is_robot} = 1;
return 1;
}
}
if(defined($remote) && $self->{cache}) {
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/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/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
ok(!defined $p->{evil}, 'disallowed key absent');
};
subtest 'params() - allow regex mismatch blocks value' => sub {
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 key excluded from result');
is($info->status(), 422, 'status 422 set on validation failure');
};
subtest 'params() - allow exact-string match' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'color=blue&color=red';
my $info = CGI::Info->new();
my $p = $info->params(allow => { 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 => pass
num2 => sub { ($_[1] % 2) == 0 }, # odd => fail
});
ok(defined $p->{num}, 'even number passes coderef validator');
ok(!defined $p->{num2}, 'odd number blocked by coderef validator');
};
subtest 'params() - SQL injection blocked (GET)' => 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();
my $p = $info->params();
ok(!defined $p, 'SQL injection blocked');
is($info->status(), 403, 'status 403 on SQL injection');
};
subtest 'params() - XSS injection blocked (GET)' => 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();
my $p = $info->params();
ok(!defined $p, 'XSS injection blocked');
is($info->status(), 403, 'status 403 on XSS');
};
subtest 'params() - directory traversal blocked (GET)' => 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 = $info->params();
ok(!defined $p, 'directory traversal blocked');
is($info->status(), 403, 'status 403 on directory traversal');
};
subtest 'params() - mustleak attack blocked (GET)' => sub {
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 attack blocked');
is($info->status(), 403, 'status 403 on mustleak');
};
subtest 'params() - duplicate values comma-joined' => sub {
reset_env();
$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING} = 'color=red&color=blue';
my $info = CGI::Info->new();
my $p = $info->params();
t/function.t view on Meta::CPAN
subtest 'params() - Params::Validate::Strict schema blocks invalid value' => 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 }
});
# Either blocked entirely or age is absent
my $blocked = (!defined $p) || (!defined $p->{age});
ok($blocked, 'out-of-range age blocked by Params::Validate::Strict');
};
done_testing();
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 1.134 second using v1.01-cache-2.11-cpan-39bf76dae61 )