mirror of
https://github.com/webmin/webmin.git
synced 2026-06-09 22:40:23 +01:00
1478 lines
60 KiB
Perl
1478 lines
60 KiB
Perl
#!/usr/bin/perl
|
||
# Unit tests for miniserv.pl helper subs.
|
||
#
|
||
# miniserv.pl is loaded as a module; its top-level script body is skipped
|
||
# by the `unless (caller) { ... }` guard, so we only get the sub
|
||
# definitions plus a handful of pure-constant globals (@itoa64, @weekday,
|
||
# @month, @miniserv_argv). Everything else (%config, @roots, $datestr,
|
||
# etc.) we populate ourselves.
|
||
#
|
||
# Each helper has its own `subtest`. Assertions target the contract
|
||
# (status code present, headers present, redaction happened, round-trip
|
||
# is identity, ...), not the exact wording, HTML, or formatting — those
|
||
# are presentation and may change.
|
||
|
||
use strict;
|
||
use warnings;
|
||
use Test::More;
|
||
use File::Basename qw(dirname);
|
||
use File::Spec;
|
||
|
||
my $script = File::Spec->rel2abs(
|
||
File::Spec->catfile(dirname(__FILE__), '..', 'miniserv.pl'));
|
||
require $script;
|
||
|
||
# Capture buffers populated by overridden I/O subs.
|
||
our @written;
|
||
our @errlog;
|
||
our @reqlog;
|
||
|
||
# Replace the subs that would otherwise touch SOCK, STDERR, the log file,
|
||
# or read disk. Each capturing override is the minimum needed to keep
|
||
# the subs under test runnable. `once` is suppressed because these
|
||
# package globals are only ever written from this file.
|
||
{
|
||
no warnings qw(redefine once);
|
||
*miniserv::write_data = sub { push @written, join('', @_); };
|
||
*miniserv::write_keep_alive = sub { };
|
||
*miniserv::log_error = sub { push @errlog, join('', @_); };
|
||
*miniserv::log_request = sub { push @reqlog, [@_]; };
|
||
*miniserv::embed_error_styles = sub { return ''; };
|
||
*miniserv::server_info = sub { return 'MiniServ/test'; };
|
||
*miniserv::reset_byte_count = sub { };
|
||
*miniserv::byte_count = sub { return 0; };
|
||
}
|
||
|
||
{
|
||
no warnings 'once';
|
||
%miniserv::config = ();
|
||
@miniserv::roots = ('/tmp');
|
||
@miniserv::preroots = ();
|
||
$miniserv::datestr = 'Sun, 01 Jan 2026 00:00:00 GMT';
|
||
}
|
||
|
||
# http_error
|
||
#
|
||
# Call http_error with capture buffers reset. noexit=1 is REQUIRED — the
|
||
# real sub calls exit() otherwise. Warnings about SOCK (not a real socket)
|
||
# and DEBUG (filehandle never opened in tests) are expected and filtered;
|
||
# any other warning fails the test so real regressions stay visible.
|
||
sub run_http_error {
|
||
my (%args) = @_;
|
||
@written = ();
|
||
@errlog = ();
|
||
@reqlog = ();
|
||
no warnings 'once';
|
||
local $miniserv::reqline = $args{reqline};
|
||
local $miniserv::loghost = $args{loghost};
|
||
local $miniserv::authuser = $args{authuser};
|
||
|
||
my @warnings;
|
||
local $SIG{__WARN__} = sub { push @warnings, $_[0]; };
|
||
miniserv::http_error(
|
||
$args{code}, $args{msg}, $args{body},
|
||
1, # noexit
|
||
$args{noerr},
|
||
);
|
||
|
||
my @unexpected = grep { !/\b(?:SOCK|DEBUG)\b/ } @warnings;
|
||
is(scalar @unexpected, 0, 'no unexpected warnings from http_error')
|
||
or diag("unexpected warnings:\n", @unexpected);
|
||
|
||
return join('', @written);
|
||
}
|
||
|
||
subtest 'http_error' => sub {
|
||
# minimal call: code + message, no body, no reqline
|
||
# Assert on the contract, not the cosmetics: the status code, the
|
||
# presence of required headers, and that the caller's code + message
|
||
# reach the rendered page. Specific wording, header values, decoration
|
||
# (—), and class names are presentation and may change.
|
||
{
|
||
my $out = run_http_error(code => 404, msg => 'Not Found');
|
||
|
||
like($out, qr{^HTTP/1\.0 404\b}, 'status line carries 404');
|
||
like($out, qr{\r\nServer:\s+\S}, 'Server header present and non-empty');
|
||
like($out, qr{\r\nDate:\s+\S}, 'Date header present and non-empty');
|
||
like($out, qr{\r\nContent-type:\s*text/html\b.*\butf-?8\b}i, 'Content-type is HTML with utf-8 charset');
|
||
like($out, qr{<title>[^<]*404[^<]*</title>}, 'title surfaces the code');
|
||
like($out, qr{<title>[^<]*Not Found[^<]*</title>}, 'title surfaces the message');
|
||
like($out, qr{<h2\b[^>]*>[^<]*Not Found[^<]*</h2>}, 'message appears in a heading');
|
||
unlike($out, qr{<p\b}, 'no paragraph emitted when body arg absent');
|
||
|
||
is(scalar @errlog, 1, 'log_error called once');
|
||
like($errlog[0], qr/Not Found/, 'log_error received the caller message');
|
||
is(scalar @reqlog, 0, 'log_request skipped when reqline empty');
|
||
}
|
||
|
||
# body argument renders as a paragraph
|
||
{
|
||
my $out = run_http_error(code => 500, msg => 'Server Error', body => 'something broke');
|
||
like($out, qr{<p\b[^>]*>[^<]*\Qsomething broke\E[^<]*</p>}, 'body argument rendered in a paragraph');
|
||
}
|
||
|
||
# reqline triggers log_request
|
||
{
|
||
run_http_error(
|
||
code => 403, msg => 'Forbidden', body => 'no access',
|
||
reqline => 'GET /secret HTTP/1.0',
|
||
loghost => '127.0.0.1', authuser => 'bob',
|
||
);
|
||
is(scalar @reqlog, 1, 'log_request called when reqline is set');
|
||
is($reqlog[0][0], '127.0.0.1', 'log_request host arg');
|
||
is($reqlog[0][1], 'bob', 'log_request user arg');
|
||
is($reqlog[0][2], 'GET /secret HTTP/1.0', 'log_request request arg');
|
||
is($reqlog[0][3], 403, 'log_request code arg');
|
||
}
|
||
|
||
# noerr suppresses log_error
|
||
{
|
||
run_http_error(code => 401, msg => 'Unauthorized', noerr => 1);
|
||
is(scalar @errlog, 0, 'log_error suppressed when noerr is true');
|
||
}
|
||
|
||
# error_handler config that points to a missing file falls through
|
||
# This exercises the early branch without triggering `goto rerun` (which
|
||
# only resolves inside handle_request).
|
||
{
|
||
local $miniserv::config{'error_handler'} = 'definitely-not-a-real-file.cgi';
|
||
my $out = run_http_error(code => 500, msg => 'Server Error');
|
||
like($out, qr{^HTTP/1\.0 500\b}, 'falls through to standard path when handler file missing');
|
||
}
|
||
|
||
# HTML scaffolding is balanced
|
||
{
|
||
my $out = run_http_error(code => 400, msg => 'Bad Request', body => 'oops');
|
||
for my $tag (qw(html head title body h2 p)) {
|
||
my $open = () = $out =~ /<$tag\b[^>]*>/g;
|
||
my $close = () = $out =~ /<\/$tag>/g;
|
||
is($open, $close, "<$tag> tags balanced (open=$open, close=$close)");
|
||
cmp_ok($open, '>=', 1, "<$tag> appears at least once");
|
||
}
|
||
# Sanity-check element ordering: head before body, title inside head.
|
||
like($out, qr{<html>.*<head>.*<title>.*</title>.*</head>.*<body[^>]*>.*</body>\s*</html>}s,
|
||
'top-level elements appear in the expected order');
|
||
}
|
||
};
|
||
|
||
# simplify_path — security-critical path canonicalization
|
||
subtest 'simplify_path' => sub {
|
||
my $bogus;
|
||
|
||
is(miniserv::simplify_path('/foo/bar', $bogus), '/foo/bar', 'plain path passes through');
|
||
is($bogus, 0, 'plain path is not bogus');
|
||
|
||
is(miniserv::simplify_path('/foo/./bar', $bogus), '/foo/bar', '. segments collapse');
|
||
is(miniserv::simplify_path('/foo/../bar', $bogus), '/bar', '.. segments pop');
|
||
is($bogus, 0, 'in-bounds .. is not bogus');
|
||
|
||
miniserv::simplify_path('/../etc/passwd', $bogus);
|
||
is($bogus, 1, 'escaping above the root sets the bogus flag');
|
||
|
||
miniserv::simplify_path('/foo/../../bar', $bogus);
|
||
is($bogus, 1, 'multiple .. that overshoot set the bogus flag');
|
||
|
||
# Null bytes are stripped — relied on to prevent C-string truncation
|
||
# attacks downstream.
|
||
my $clean = miniserv::simplify_path("/foo\0bar/baz", $bogus);
|
||
unlike($clean, qr/\0/, 'null bytes are removed');
|
||
|
||
# Backslash separators get normalized to forward slashes.
|
||
is(miniserv::simplify_path('foo\\bar', $bogus), '/foo/bar', 'backslashes become forward slashes');
|
||
|
||
# Repeated slashes collapse.
|
||
is(miniserv::simplify_path('//foo///bar//', $bogus), '/foo/bar', 'repeated slashes collapse');
|
||
};
|
||
|
||
# b64encode / b64decode — round-trip is the contract
|
||
subtest 'b64encode / b64decode round-trip' => sub {
|
||
for my $s ('a', 'ab', 'abc', 'hello world',
|
||
"binary\x00\x01\xff bytes", 'x' x 100) {
|
||
is(miniserv::b64decode(miniserv::b64encode($s)), $s,
|
||
"round-trip preserves ".length($s)." bytes");
|
||
}
|
||
|
||
# Output is restricted to the standard alphabet plus padding.
|
||
like(miniserv::b64encode('hello'), qr{^[A-Za-z0-9+/=]+$},
|
||
'encoded output uses standard base64 alphabet');
|
||
};
|
||
|
||
# urlize — percent-encoding
|
||
subtest 'urlize' => sub {
|
||
is(miniserv::urlize('abc123'), 'abc123', 'alphanumerics pass through');
|
||
is(miniserv::urlize(' '), '%20', 'space percent-encoded');
|
||
is(miniserv::urlize('/'), '%2F', 'slash percent-encoded');
|
||
like(miniserv::urlize('a b/c'), qr{^a%20b%2Fc$},
|
||
'mixed string encodes non-alphanumerics, leaves alphanumerics alone');
|
||
};
|
||
|
||
# html_escape / html_strip — XSS-relevant
|
||
subtest 'html_escape' => sub {
|
||
my $out = miniserv::html_escape(q{<script>alert("x")</script>'=&});
|
||
# Contract: none of the dangerous characters survive as themselves.
|
||
unlike($out, qr/[<>"'=]/, 'no raw HTML-significant characters remain');
|
||
unlike($out, qr/&(?!(amp|lt|gt|quot|#39|#61);)/,
|
||
'every & is the start of a known entity');
|
||
# Alphanumerics pass through unchanged.
|
||
like(miniserv::html_escape('abc 123'), qr/\babc\b.*\b123\b/,
|
||
'alphanumerics pass through unchanged');
|
||
};
|
||
|
||
subtest 'html_strip' => sub {
|
||
is(miniserv::html_strip('<b>foo</b>'), 'foo', 'simple tags removed');
|
||
is(miniserv::html_strip('<a href="x">y</a>'), 'y', 'attribute-bearing tags removed');
|
||
is(miniserv::html_strip('plain text'), 'plain text', 'plain text untouched');
|
||
};
|
||
|
||
# get_type — MIME lookup
|
||
subtest 'get_type' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::mime = (html => 'text/html', png => 'image/png');
|
||
|
||
is(miniserv::get_type('foo.html'), 'text/html', 'known extension returns its type');
|
||
is(miniserv::get_type('foo.png'), 'image/png', 'second known extension');
|
||
is(miniserv::get_type('foo.unknown'), 'text/plain', 'unknown extension falls back to text/plain');
|
||
is(miniserv::get_type('noextension'), 'text/plain', 'no extension falls back to text/plain');
|
||
};
|
||
|
||
# indexof — array index utility
|
||
subtest 'indexof' => sub {
|
||
is(miniserv::indexof('b', 'a', 'b', 'c'), 1, 'returns 0-based index');
|
||
is(miniserv::indexof('a', 'a', 'b', 'c'), 0, 'first element matches');
|
||
is(miniserv::indexof('z', 'a', 'b', 'c'), -1, 'missing returns -1');
|
||
is(miniserv::indexof('x'), -1, 'empty haystack returns -1');
|
||
};
|
||
|
||
# prefix_to_mask — CIDR prefix → dotted-quad netmask
|
||
subtest 'prefix_to_mask' => sub {
|
||
is(miniserv::prefix_to_mask(0), '0.0.0.0', '/0 = all zeros');
|
||
is(miniserv::prefix_to_mask(8), '255.0.0.0', '/8');
|
||
is(miniserv::prefix_to_mask(16), '255.255.0.0', '/16');
|
||
is(miniserv::prefix_to_mask(24), '255.255.255.0', '/24');
|
||
is(miniserv::prefix_to_mask(32), '255.255.255.255', '/32 = all ones');
|
||
};
|
||
|
||
# check_ipaddress / check_ip6address — input validators
|
||
subtest 'check_ipaddress' => sub {
|
||
ok( miniserv::check_ipaddress('1.2.3.4'), 'valid IPv4 accepted');
|
||
ok( miniserv::check_ipaddress('0.0.0.0'), 'all-zero IPv4 accepted');
|
||
ok( miniserv::check_ipaddress('255.255.255.255'), 'all-ones IPv4 accepted');
|
||
ok(!miniserv::check_ipaddress('256.0.0.1'), 'octet > 255 rejected');
|
||
ok(!miniserv::check_ipaddress('1.2.3'), 'too-few octets rejected');
|
||
ok(!miniserv::check_ipaddress('1.2.3.4.5'), 'too-many octets rejected');
|
||
ok(!miniserv::check_ipaddress(''), 'empty string rejected');
|
||
ok(!miniserv::check_ipaddress('not an ip'), 'garbage rejected');
|
||
};
|
||
|
||
# Kept in lockstep with t/web-lib-funcs-ip.t's matching subtest, since the
|
||
# two copies of check_ip6address must accept and reject the same inputs.
|
||
subtest 'check_ip6address' => sub {
|
||
ok( miniserv::check_ip6address('::'), 'unspecified accepted');
|
||
ok( miniserv::check_ip6address('::1'), 'loopback accepted');
|
||
ok( miniserv::check_ip6address('2001:db8::1'), 'compressed form accepted');
|
||
ok( miniserv::check_ip6address('1:2:3:4:5:6:7:8'), 'full eight-block form accepted');
|
||
ok( miniserv::check_ip6address('2001:db8::'), 'trailing :: accepted (no netmask)');
|
||
|
||
# Netmask suffix — both with leading and trailing :: shorthand.
|
||
ok( miniserv::check_ip6address('::1/64'), 'address/netmask accepted with leading ::');
|
||
ok( miniserv::check_ip6address('2001:db8::/32'), 'address/netmask accepted with trailing ::');
|
||
ok( miniserv::check_ip6address('::/0'), '::/0 default route accepted');
|
||
ok( miniserv::check_ip6address('fe80::/10'), 'fe80::/10 link-local prefix accepted');
|
||
ok(!miniserv::check_ip6address('::1/200'), 'netmask > 128 rejected');
|
||
|
||
# IPv4-in-IPv6 tails.
|
||
ok( miniserv::check_ip6address('::ffff:10.0.0.1'), 'IPv4-mapped (::ffff:N.N.N.N) accepted');
|
||
ok( miniserv::check_ip6address('::ffff:0.0.0.0'), 'IPv4-mapped all-zero accepted');
|
||
ok( miniserv::check_ip6address('::1.2.3.4'), 'IPv4-compatible (::N.N.N.N) accepted');
|
||
ok( miniserv::check_ip6address('0:0:0:0:0:ffff:1.2.3.4'),
|
||
'fully-expanded IPv4-mapped accepted');
|
||
ok(!miniserv::check_ip6address('::ffff:256.0.0.1'), 'IPv4-mapped with octet > 255 rejected');
|
||
ok(!miniserv::check_ip6address('::ffff:1.2.3'), 'IPv4-mapped with too-few octets rejected');
|
||
|
||
# Bare IPv4 must be rejected — callers (e.g. ip_match) use this sub
|
||
# as a type discriminator and a true result re-routes IPv4 input
|
||
# through the IPv6 codepath.
|
||
ok(!miniserv::check_ip6address('10.0.0.1'), 'bare IPv4 rejected (type-discriminator contract)');
|
||
ok(!miniserv::check_ip6address('1.2.3.4'), 'bare IPv4 rejected (type-discriminator contract)');
|
||
|
||
# Degenerate netmask shapes — stripping "/N" from the input must not
|
||
# let an address that's otherwise just a stray colon (or empty) pass.
|
||
# perl's split() trims trailing empties hard, so e.g. split(":") is
|
||
# () not (""), and our @blocks==0 guard catches it.
|
||
ok(!miniserv::check_ip6address(':/64'), 'bare colon with netmask rejected');
|
||
ok(!miniserv::check_ip6address('/64'), 'netmask without address rejected');
|
||
ok(!miniserv::check_ip6address(':'), 'bare colon rejected');
|
||
ok(!miniserv::check_ip6address('::/'), 'trailing slash with no digits rejected');
|
||
ok(!miniserv::check_ip6address('//64'), 'leading slash with netmask rejected');
|
||
|
||
ok(!miniserv::check_ip6address('gggg::1'), 'non-hex rejected');
|
||
ok(!miniserv::check_ip6address('1:2:3:4:5:6:7:8:9'), 'too many groups rejected');
|
||
ok(!miniserv::check_ip6address('::1::2'), 'multiple :: rejected');
|
||
ok(!miniserv::check_ip6address('not an addr'), 'garbage rejected');
|
||
};
|
||
|
||
# canonicalize_ip6 / expand_ipv6_bytes
|
||
subtest 'canonicalize_ip6' => sub {
|
||
my $c = miniserv::canonicalize_ip6('::1');
|
||
is($c, '0000:0000:0000:0000:0000:0000:0000:0001',
|
||
'::1 expands to 8 zero-padded groups');
|
||
|
||
my $c2 = miniserv::canonicalize_ip6('2001:DB8::1');
|
||
is($c2, '2001:0db8:0000:0000:0000:0000:0000:0001',
|
||
'2001:DB8::1 lower-cased and zero-expanded');
|
||
|
||
# Idempotency: running canonicalize on canonical input returns the same.
|
||
is(miniserv::canonicalize_ip6($c), $c, 'canonical form is idempotent');
|
||
};
|
||
|
||
subtest 'expand_ipv6_bytes' => sub {
|
||
my @bytes = miniserv::expand_ipv6_bytes(
|
||
miniserv::canonicalize_ip6('::1'));
|
||
is(scalar @bytes, 16, 'IPv6 expands to 16 bytes');
|
||
is($bytes[15], 1, 'low byte is 1 for ::1');
|
||
is($bytes[0], 0, 'high byte is 0 for ::1');
|
||
};
|
||
|
||
# is_bad_header — ShellShock guard
|
||
subtest 'is_bad_header' => sub {
|
||
ok( miniserv::is_bad_header('() { :; }; echo pwned'), 'ShellShock-shaped value flagged');
|
||
ok( miniserv::is_bad_header(' () { x'), 'leading whitespace still flagged');
|
||
ok(!miniserv::is_bad_header('Mozilla/5.0'), 'plain value not flagged');
|
||
ok(!miniserv::is_bad_header('text/html'), 'plain value with no parens not flagged');
|
||
};
|
||
|
||
# is_mobile_useragent
|
||
subtest 'is_mobile_useragent' => sub {
|
||
no warnings 'once';
|
||
local @miniserv::mobile_agents = ();
|
||
|
||
ok( miniserv::is_mobile_useragent('Mozilla/5.0 (iPhone; CPU iPhone OS)'),
|
||
'iPhone UA detected');
|
||
ok( miniserv::is_mobile_useragent('Nokia6230/2.0'),
|
||
'Nokia prefix detected');
|
||
ok( miniserv::is_mobile_useragent('Mozilla/5.0 (Linux; Android 10; Mobile)'),
|
||
'Android-mobile regexp matched');
|
||
ok(!miniserv::is_mobile_useragent('Mozilla/5.0 (X11; Linux x86_64)'),
|
||
'desktop Linux not flagged');
|
||
ok(!miniserv::is_mobile_useragent('curl/7.88.1'),
|
||
'curl not flagged');
|
||
};
|
||
|
||
# http_date — RFC 1123 GMT date
|
||
subtest 'http_date' => sub {
|
||
my $d = miniserv::http_date(0);
|
||
# 1970-01-01 00:00:00 GMT
|
||
like($d, qr/^Thu,\s+1\s+Jan\s+1970\s+00:00:00\s+GMT$/,
|
||
'unix epoch formatted as RFC GMT date');
|
||
|
||
like(miniserv::http_date(time()),
|
||
qr/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat),\s+\d{1,2}\s+(?:Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\s+\d{4}\s+\d{2}:\d{2}:\d{2}\s+GMT$/,
|
||
'current time matches RFC GMT shape');
|
||
};
|
||
|
||
# split_userdb_string — userdb URI parser
|
||
subtest 'split_userdb_string' => sub {
|
||
my @r = miniserv::split_userdb_string(
|
||
'mysql://admin:secret@db.example.com/webmin?ssl=1&port=3307');
|
||
is(scalar @r, 6, 'valid URI parses to 6 elements');
|
||
is($r[0], 'mysql', 'protocol');
|
||
is($r[1], 'admin', 'username');
|
||
is($r[2], 'secret', 'password');
|
||
is($r[3], 'db.example.com', 'host');
|
||
is($r[4], 'webmin', 'prefix');
|
||
is(ref($r[5]), 'HASH', 'args is a hashref');
|
||
is($r[5]->{ssl}, '1', 'ssl arg');
|
||
is($r[5]->{port}, '3307', 'port arg');
|
||
|
||
is_deeply([miniserv::split_userdb_string('not a url')], [],
|
||
'unparseable input returns empty list');
|
||
};
|
||
|
||
# get_logged_sensitive_params / sanitise_logged_request
|
||
subtest 'get_logged_sensitive_params' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::config = ();
|
||
|
||
my @defaults = miniserv::get_logged_sensitive_params();
|
||
# Contract: default list covers the common sensitive param names.
|
||
for my $expected (qw(password pass passwd token api_key secret)) {
|
||
ok((grep { lc($_) eq $expected } @defaults),
|
||
"default list contains '$expected'");
|
||
}
|
||
|
||
local $miniserv::config{'log_redact_params'} = 'mycustom, another';
|
||
my @plus = miniserv::get_logged_sensitive_params();
|
||
ok((grep { $_ eq 'mycustom' } @plus), 'log_redact_params adds custom name');
|
||
ok((grep { $_ eq 'another' } @plus), 'log_redact_params is comma-separable');
|
||
|
||
# Dedup: configuring an existing default name does not duplicate.
|
||
local $miniserv::config{'log_redact_params'} = 'password';
|
||
my @dup = miniserv::get_logged_sensitive_params();
|
||
my @pw = grep { lc($_) eq 'password' } @dup;
|
||
is(scalar @pw, 1, 'duplicate of default name is deduplicated');
|
||
};
|
||
|
||
subtest 'sanitise_logged_request' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::config = ();
|
||
|
||
my $req = 'GET /login?user=alice&password=hunter2 HTTP/1.1';
|
||
my $out = miniserv::sanitise_logged_request($req);
|
||
|
||
unlike($out, qr/hunter2/, 'sensitive value removed');
|
||
like ($out, qr/user=alice/, 'non-sensitive param preserved');
|
||
like ($out, qr{^GET\s+/login\?.*HTTP/1\.1$}, 'request line shape preserved');
|
||
|
||
# Multiple sensitive params on one line.
|
||
my $multi = 'GET /x?token=abc&api_key=def&q=keep HTTP/1.0';
|
||
my $mout = miniserv::sanitise_logged_request($multi);
|
||
unlike($mout, qr/abc/, 'token value removed');
|
||
unlike($mout, qr/def/, 'api_key value removed');
|
||
like ($mout, qr/q=keep/, 'non-sensitive value preserved');
|
||
|
||
# Custom redacted param from config.
|
||
local $miniserv::config{'log_redact_params'} = 'sessionid';
|
||
my $custom = miniserv::sanitise_logged_request(
|
||
'GET /x?sessionid=zzz HTTP/1.1');
|
||
unlike($custom, qr/zzz/, 'custom-configured param value removed');
|
||
|
||
# Undef input survives.
|
||
is(miniserv::sanitise_logged_request(undef), undef,
|
||
'undef input passes through');
|
||
|
||
# Non-request strings pass through unchanged.
|
||
is(miniserv::sanitise_logged_request('not a request line'),
|
||
'not a request line',
|
||
'non-request input passes through unchanged');
|
||
};
|
||
|
||
# matches_cron
|
||
subtest 'matches_cron' => sub {
|
||
ok( miniserv::matches_cron('*', 5, 0), '* matches anything');
|
||
ok( miniserv::matches_cron('5', 5, 0), 'exact match');
|
||
ok(!miniserv::matches_cron('6', 5, 0), 'mismatch returns false');
|
||
ok( miniserv::matches_cron('1,5,9', 5, 0), 'comma list match');
|
||
ok(!miniserv::matches_cron('1,9', 5, 0), 'comma list miss');
|
||
ok( miniserv::matches_cron('1-10', 5, 0), 'range match');
|
||
ok(!miniserv::matches_cron('1-4', 5, 0), 'range miss');
|
||
ok( miniserv::matches_cron('*/5', 10, 0), 'step match');
|
||
ok(!miniserv::matches_cron('*/5', 7, 0), 'step miss');
|
||
};
|
||
|
||
# ip_match — host-based ACL matching (IPv4 only, no DNS branches)
|
||
subtest 'ip_match' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::ip_match_cache = ();
|
||
|
||
# ip_match rewrites $_[N] in place when converting CIDR to netmask,
|
||
# so each rule must be passed as a scalar — not a string literal.
|
||
my $check = sub {
|
||
my ($remote, $local, @rules) = @_;
|
||
return miniserv::ip_match($remote, $local, @rules);
|
||
};
|
||
|
||
my $exact_match_rule = '1.2.3.4';
|
||
my $exact_miss_rule = '1.2.3.5';
|
||
my $cidr_match_rule = '1.2.3.0/24';
|
||
my $cidr_miss_rule = '1.2.4.0/24';
|
||
my $netmask_rule = '10.0.0.0/255.0.0.0';
|
||
my $range_rule = '1.2.3.5-1.2.3.15';
|
||
my $partial_rule = '1.2.3';
|
||
my $multi_miss_rule = '9.9.9.9';
|
||
my $multi_match_rule = '1.2.3.4';
|
||
|
||
# Exact match.
|
||
ok( $check->('1.2.3.4', '5.6.7.8', $exact_match_rule),
|
||
'exact IPv4 match');
|
||
ok(!$check->('1.2.3.4', '5.6.7.8', $exact_miss_rule),
|
||
'one-off IPv4 mismatch');
|
||
|
||
# CIDR.
|
||
ok( $check->('1.2.3.4', '5.6.7.8', $cidr_match_rule),
|
||
'CIDR /24 match');
|
||
ok(!$check->('1.2.3.4', '5.6.7.8', $cidr_miss_rule),
|
||
'CIDR /24 miss');
|
||
|
||
# Netmask form.
|
||
ok( $check->('10.0.0.5', '5.6.7.8', $netmask_rule),
|
||
'netmask form match');
|
||
|
||
# Range form.
|
||
ok( $check->('1.2.3.10', '5.6.7.8', $range_rule),
|
||
'range form match');
|
||
ok(!$check->('1.2.3.20', '5.6.7.8', $range_rule),
|
||
'range form miss');
|
||
|
||
# Partial address.
|
||
ok( $check->('1.2.3.4', '5.6.7.8', $partial_rule),
|
||
'partial address /24-equivalent match');
|
||
|
||
# Multiple rules: any match wins.
|
||
ok( $check->('1.2.3.4', '5.6.7.8', $multi_miss_rule, $multi_match_rule),
|
||
'second rule matches when first does not');
|
||
};
|
||
|
||
# users_match — user-list matching (username branch only; the range
|
||
# branch references a different `@uinfo` global and the group branch
|
||
# calls getgrnam, so we test only the contract we'd refactor against).
|
||
subtest 'users_match (username branch)' => sub {
|
||
my $uinfo = ['alice', 'x', 1000, 1000];
|
||
|
||
ok( miniserv::users_match($uinfo, 'alice'), 'matching username returns true');
|
||
ok( miniserv::users_match($uinfo, 'bob', 'alice'), 'matches against any in the list');
|
||
ok(!miniserv::users_match($uinfo, 'bob', 'carol'), 'no match returns false');
|
||
ok(!miniserv::users_match($uinfo), 'empty user list returns false');
|
||
};
|
||
|
||
# websocket origin parsing — security-critical for CSWSH prevention
|
||
subtest 'normalise_websocket_origin' => sub {
|
||
is(miniserv::normalise_websocket_origin('http', 'example.com', 80),
|
||
'http://example.com', 'default port 80 dropped for http');
|
||
is(miniserv::normalise_websocket_origin('https', 'example.com', 443),
|
||
'https://example.com', 'default port 443 dropped for https');
|
||
is(miniserv::normalise_websocket_origin('http', 'example.com', 8080),
|
||
'http://example.com:8080', 'non-default port kept');
|
||
is(miniserv::normalise_websocket_origin('HTTP', 'Example.COM', 80),
|
||
'http://example.com', 'scheme and host lower-cased');
|
||
is(miniserv::normalise_websocket_origin('http', '[::1]', 8080),
|
||
'http://[::1]:8080', 'bracketed IPv6 host preserved');
|
||
is(miniserv::normalise_websocket_origin('http', '', 80), undef,
|
||
'empty host returns undef');
|
||
is(miniserv::normalise_websocket_origin('', 'example.com', 80), undef,
|
||
'empty scheme returns undef');
|
||
};
|
||
|
||
subtest 'parse_websocket_origin' => sub {
|
||
is(miniserv::parse_websocket_origin('http://example.com'),
|
||
'http://example.com', 'plain origin');
|
||
is(miniserv::parse_websocket_origin('https://example.com:8443'),
|
||
'https://example.com:8443', 'origin with port');
|
||
is(miniserv::parse_websocket_origin('http://[2001:db8::1]:80'),
|
||
'http://[2001:db8::1]', 'IPv6 with default port stripped');
|
||
is(miniserv::parse_websocket_origin(undef), undef, 'undef rejected');
|
||
is(miniserv::parse_websocket_origin(''), undef, 'empty rejected');
|
||
is(miniserv::parse_websocket_origin('null'), undef, 'literal "null" rejected');
|
||
is(miniserv::parse_websocket_origin('ftp://example.com'), undef,
|
||
'non-http(s) scheme rejected');
|
||
is(miniserv::parse_websocket_origin('not a url'), undef,
|
||
'garbage rejected');
|
||
};
|
||
|
||
subtest 'parse_configured_websocket_origin' => sub {
|
||
is(miniserv::parse_configured_websocket_origin('ws://example.com'),
|
||
'http://example.com', 'ws:// normalized to http://');
|
||
is(miniserv::parse_configured_websocket_origin('wss://example.com'),
|
||
'https://example.com', 'wss:// normalized to https://');
|
||
is(miniserv::parse_configured_websocket_origin('http://example.com'),
|
||
'http://example.com', 'http:// passes through');
|
||
};
|
||
|
||
subtest 'forwarded_websocket_origin' => sub {
|
||
is(miniserv::forwarded_websocket_origin('http', 'example.com', 8080),
|
||
'http://example.com:8080', 'direct args');
|
||
|
||
# Comma-separated forwarded headers: take the first.
|
||
is(miniserv::forwarded_websocket_origin('http, https', 'a.com, b.com', 80),
|
||
'http://a.com', 'first comma-separated value used');
|
||
|
||
# Host header that embeds a port.
|
||
is(miniserv::forwarded_websocket_origin('http', 'example.com:8080', undef),
|
||
'http://example.com:8080', 'port embedded in host arg extracted');
|
||
|
||
# Bracketed IPv6 host with port.
|
||
is(miniserv::forwarded_websocket_origin('http', '[::1]:8080', undef),
|
||
'http://[::1]:8080', 'bracketed IPv6 host+port handled');
|
||
|
||
is(miniserv::forwarded_websocket_origin(undef, 'example.com', 80),
|
||
undef, 'missing proto returns undef');
|
||
is(miniserv::forwarded_websocket_origin('http', undef, 80),
|
||
undef, 'missing host returns undef');
|
||
};
|
||
|
||
# ssl_hostname_match — wildcard cert matching
|
||
subtest 'ssl_hostname_match' => sub {
|
||
is(miniserv::ssl_hostname_match('example.com', ['example.com']), 1,
|
||
'exact match');
|
||
is(miniserv::ssl_hostname_match('Example.COM', ['example.com']), 1,
|
||
'case-insensitive');
|
||
is(miniserv::ssl_hostname_match('foo.example.com', ['*.example.com']), 1,
|
||
'wildcard subdomain match');
|
||
is(miniserv::ssl_hostname_match('example.com', ['*.example.com']), 1,
|
||
'wildcard accepts apex too');
|
||
is(miniserv::ssl_hostname_match('other.com', ['example.com']), 0,
|
||
'no match returns 0');
|
||
is(miniserv::ssl_hostname_match('anything.tld', ['*']), 2,
|
||
'bare * returns 2');
|
||
is(miniserv::ssl_hostname_match('example.com:8443', ['example.com']), 1,
|
||
':port suffix is stripped before matching');
|
||
};
|
||
|
||
# Capability probes used by the crypto subtests below. miniserv.pl's
|
||
# detection logic runs inside its `unless(caller)` block, so when we load
|
||
# it as a module the $use_md5 / $use_sha512 / $use_hmac_sha256 globals are
|
||
# undef. Recreate them here from the same probes miniserv.pl uses itself.
|
||
my $have_md5 = eval {
|
||
require Digest::MD5;
|
||
Digest::MD5->new->add('x');
|
||
'Digest::MD5';
|
||
};
|
||
my $have_sha512 = miniserv::unix_crypt_supports_sha512() ? 1 : 0;
|
||
my $have_hmac = eval {
|
||
require Digest::SHA;
|
||
Digest::SHA::hmac_sha256_hex('x', 'y');
|
||
1;
|
||
};
|
||
|
||
# to64 — itoa64 base64-style encoder used by encrypt_md5
|
||
#
|
||
# Indexes into @itoa64 ("./0123456789A-Za-z"). Output is exactly $n chars;
|
||
# input is processed 6 bits at a time, low bits first.
|
||
subtest 'to64' => sub {
|
||
is(miniserv::to64(0, 1), '.', 'index 0 → .');
|
||
is(miniserv::to64(1, 1), '/', 'index 1 → /');
|
||
is(miniserv::to64(2, 1), '0', 'index 2 → 0');
|
||
is(miniserv::to64(63, 1), 'z', 'index 63 → z (last alphabet char)');
|
||
|
||
is(length(miniserv::to64(0, 4)), 4, 'output length = requested digits');
|
||
is(length(miniserv::to64(0xffffff, 4)), 4, 'output length is constant, not entropy-dependent');
|
||
|
||
like(miniserv::to64(0xabcdef, 4), qr{^[./0-9A-Za-z]{4}$},
|
||
'output uses only the itoa64 alphabet');
|
||
|
||
# 0x3f occupies the low 6 bits → first char z, remaining shifts → dots.
|
||
is(miniserv::to64(0x3f, 4), 'z...', 'low-bits-first ordering');
|
||
};
|
||
|
||
# encrypt_md5 — $1$ MD5-crypt
|
||
#
|
||
# Security-critical: this hashes user passwords. Contract we pin:
|
||
# - salt is preserved verbatim in the output
|
||
# - hash body is 22 itoa64 chars
|
||
# - deterministic for the same input
|
||
# - passing a full $1$salt$hash form re-extracts the salt (verification)
|
||
# - a different password produces a different hash
|
||
subtest 'encrypt_md5' => sub {
|
||
plan skip_all => 'Digest::MD5 not available' if !$have_md5;
|
||
no warnings 'once';
|
||
local $miniserv::use_md5 = $have_md5;
|
||
|
||
my $h = miniserv::encrypt_md5('password', 'abcdefgh');
|
||
like($h, qr{^\$1\$abcdefgh\$[./0-9A-Za-z]{22}$},
|
||
'$1$<salt>$<22-char hash> shape');
|
||
is(miniserv::encrypt_md5('password', 'abcdefgh'), $h, 'deterministic');
|
||
is(miniserv::encrypt_md5('password', $h), $h,
|
||
'salt re-extracted from $1$salt$hash form (verification round-trip)');
|
||
isnt(miniserv::encrypt_md5('wrong', $h), $h,
|
||
'different password → different hash');
|
||
|
||
# No-salt form skips the iteration loop and returns just the body.
|
||
my $bare = miniserv::encrypt_md5('password');
|
||
unlike($bare, qr{\$}, 'no-salt form has no $-prefix');
|
||
like ($bare, qr{^[./0-9A-Za-z]+$}, 'no-salt form uses itoa64 alphabet');
|
||
};
|
||
|
||
# unix_crypt — thin wrapper over libc crypt (or Crypt::UnixCrypt)
|
||
subtest 'unix_crypt' => sub {
|
||
no warnings 'once';
|
||
local $miniserv::use_perl_crypt;
|
||
my $h = miniserv::unix_crypt('password', 'xy');
|
||
is(length($h), 13, 'classic DES crypt output is 13 chars');
|
||
like($h, qr{^xy}, 'salt is the prefix of the output');
|
||
is (miniserv::unix_crypt('password', $h), $h, 'verification round-trip');
|
||
isnt(miniserv::unix_crypt('wrong', $h), $h, 'wrong password → different hash');
|
||
};
|
||
|
||
# unix_crypt_supports_sha512 — capability probe used at startup
|
||
subtest 'unix_crypt_supports_sha512' => sub {
|
||
my $r = miniserv::unix_crypt_supports_sha512();
|
||
ok(defined($r), 'returns a defined value');
|
||
ok($r == 0 || $r == 1, 'returns 0 or 1');
|
||
};
|
||
|
||
# encrypt_sha512 — $6$ SHA512-crypt via libc crypt()
|
||
subtest 'encrypt_sha512' => sub {
|
||
plan skip_all => 'crypt() does not support SHA512 on this system'
|
||
if !$have_sha512;
|
||
|
||
my $h = miniserv::encrypt_sha512('password', '$6$testtest$');
|
||
like($h, qr{^\$6\$testtest\$}, '$6$<salt>$ prefix preserved');
|
||
cmp_ok(length($h), '>', 50,
|
||
'SHA512 output is much longer than DES (DES is 13 chars)');
|
||
|
||
is (miniserv::encrypt_sha512('password', $h), $h,
|
||
'deterministic for same (password, salt) — verification round-trip');
|
||
isnt(miniserv::encrypt_sha512('wrong', $h), $h,
|
||
'different password → different hash');
|
||
like(miniserv::encrypt_sha512('password'), qr{^\$6\$},
|
||
'no-salt path synthesises $6$ salt');
|
||
};
|
||
|
||
# password_crypt — verifies a stored hash by recomputing
|
||
#
|
||
# The salt parameter doubles as the expected output: the caller passes the
|
||
# stored hash, and password_crypt returns the recomputed hash. Equality means
|
||
# "password matches". A non-$1$/$6$ salt (or unsupported module) falls through
|
||
# to plain crypt().
|
||
subtest 'password_crypt' => sub {
|
||
no warnings 'once';
|
||
local $miniserv::use_md5 = $have_md5;
|
||
local $miniserv::use_sha512 = $have_sha512;
|
||
local $miniserv::use_perl_crypt;
|
||
|
||
SKIP: {
|
||
skip 'Digest::MD5 not available', 2 if !$have_md5;
|
||
my $stored = miniserv::encrypt_md5('hunter2', 'abcdefgh');
|
||
is (miniserv::password_crypt('hunter2', $stored), $stored,
|
||
'$1$ stored hash + correct password verifies');
|
||
isnt(miniserv::password_crypt('wrong', $stored), $stored,
|
||
'$1$ stored hash + wrong password does not verify');
|
||
}
|
||
|
||
SKIP: {
|
||
skip 'SHA512 crypt not available', 2 if !$have_sha512;
|
||
my $stored = miniserv::encrypt_sha512('hunter2', '$6$testtest$');
|
||
is (miniserv::password_crypt('hunter2', $stored), $stored,
|
||
'$6$ stored hash + correct password verifies');
|
||
isnt(miniserv::password_crypt('wrong', $stored), $stored,
|
||
'$6$ stored hash + wrong password does not verify');
|
||
}
|
||
|
||
# 2-char salt → DES fallback (no $1$/$6$ branch taken).
|
||
my $des = miniserv::unix_crypt('hunter2', 'xy');
|
||
is(miniserv::password_crypt('hunter2', $des), $des,
|
||
'DES stored hash + correct password verifies');
|
||
};
|
||
|
||
# hash_session_id — three independent code paths, picked by which crypto
|
||
# globals are set. Each branch gets its own subtest so the cache and globals
|
||
# can be reset cleanly via `local`.
|
||
|
||
subtest 'hash_session_id (HMAC-SHA256 branch)' => sub {
|
||
plan skip_all => 'Digest::SHA hmac_sha256_hex not available' if !$have_hmac;
|
||
no warnings 'once';
|
||
local $miniserv::use_hmac_sha256 = 1;
|
||
local $miniserv::session_hmac_key = 'a' x 32;
|
||
local %miniserv::hash_session_id_cache = ();
|
||
|
||
my $h = miniserv::hash_session_id('sess123');
|
||
like($h, qr{^[0-9a-f]{64}$}, 'HMAC-SHA256 hex output: 64 hex chars');
|
||
is (miniserv::hash_session_id('sess123'), $h,
|
||
'second call for same sid is cached (and stable)');
|
||
isnt(miniserv::hash_session_id('other'), $h,
|
||
'different sid → different hash');
|
||
|
||
# Different key must change the hash for the same input.
|
||
%miniserv::hash_session_id_cache = ();
|
||
local $miniserv::session_hmac_key = 'b' x 32;
|
||
isnt(miniserv::hash_session_id('sess123'), $h,
|
||
'different HMAC key → different hash for the same sid');
|
||
};
|
||
|
||
subtest 'hash_session_id (MD5 branch)' => sub {
|
||
plan skip_all => 'Digest::MD5 not available' if !$have_md5;
|
||
no warnings 'once';
|
||
local $miniserv::use_hmac_sha256 = 0;
|
||
local $miniserv::session_hmac_key = undef;
|
||
local $miniserv::use_md5 = $have_md5;
|
||
local %miniserv::hash_session_id_cache = ();
|
||
|
||
my $h = miniserv::hash_session_id('sess123');
|
||
like($h, qr{^[./0-9A-Za-z]{22}$},
|
||
'MD5 (no-salt) form: 22 itoa64 chars');
|
||
is(miniserv::hash_session_id('sess123'), $h, 'cached on second call');
|
||
};
|
||
|
||
subtest 'hash_session_id (unix_crypt fallback)' => sub {
|
||
no warnings 'once';
|
||
local $miniserv::use_hmac_sha256 = 0;
|
||
local $miniserv::session_hmac_key = undef;
|
||
local $miniserv::use_md5 = undef;
|
||
local %miniserv::hash_session_id_cache = ();
|
||
|
||
my $h = miniserv::hash_session_id('sess123');
|
||
is(length($h), 13, 'DES crypt fallback is 13 chars');
|
||
is(miniserv::hash_session_id('sess123'), $h, 'cached on second call');
|
||
};
|
||
|
||
# generate_random_id — session ID generator
|
||
#
|
||
# Two paths: /dev/urandom (preferred) and a rand()-based fallback. The
|
||
# fallback should still produce a 32-char lowercase hex string. With
|
||
# force_urandom=1 and /dev/urandom marked bad, the function must return
|
||
# undef rather than fall back silently.
|
||
subtest 'generate_random_id' => sub {
|
||
no warnings 'once';
|
||
|
||
# Fallback path: pretend /dev/urandom is unusable, allow fallback.
|
||
{
|
||
local $miniserv::bad_urandom = 1;
|
||
my $sid = miniserv::generate_random_id();
|
||
like($sid, qr{^[0-9a-f]{32}$}, 'fallback produces 32-char lowercase hex id');
|
||
isnt(miniserv::generate_random_id(), $sid,
|
||
'two fallback calls produce different ids');
|
||
}
|
||
|
||
# /dev/urandom path, when available.
|
||
SKIP: {
|
||
skip '/dev/urandom not readable', 1 if !-r '/dev/urandom';
|
||
local $miniserv::bad_urandom = 0;
|
||
my $sid = miniserv::generate_random_id();
|
||
like($sid, qr{^[0-9a-f]{32}$},
|
||
'/dev/urandom path produces 32-char lowercase hex id');
|
||
}
|
||
|
||
# force_urandom=1 + bad_urandom → no fallback, returns undef.
|
||
{
|
||
local $miniserv::bad_urandom = 1;
|
||
is(miniserv::generate_random_id(1), undef,
|
||
'force_urandom=1 with bad_urandom returns undef (no silent fallback)');
|
||
}
|
||
};
|
||
|
||
# check_user_time — login allowed by current date/time?
|
||
#
|
||
# Pure logic over a $uinfo hashref once get_user_details is stubbed. We
|
||
# anchor allow-window tests around the current minute-of-day so they pass
|
||
# regardless of when the suite runs.
|
||
subtest 'check_user_time' => sub {
|
||
no warnings qw(redefine once);
|
||
my $uinfo;
|
||
local *miniserv::get_user_details = sub { $uinfo };
|
||
|
||
# Unknown user → allowed (returns 1 early).
|
||
$uinfo = undef;
|
||
ok(miniserv::check_user_time('alice'), 'unknown user → allowed');
|
||
|
||
# Known user with no restrictions → allowed.
|
||
$uinfo = { 'name' => 'alice' };
|
||
ok(miniserv::check_user_time('alice'),
|
||
'user with no allowdays/allowhours → allowed');
|
||
|
||
my @tm = localtime(time());
|
||
my $today = $tm[6];
|
||
my $not_today = ($today + 3) % 7;
|
||
my $now_min = $tm[2] * 60 + $tm[1];
|
||
|
||
$uinfo = { 'allowdays' => [$today] };
|
||
ok(miniserv::check_user_time('alice'), 'current weekday in allowdays → allowed');
|
||
|
||
$uinfo = { 'allowdays' => [$not_today] };
|
||
ok(!miniserv::check_user_time('alice'), 'current weekday not in allowdays → denied');
|
||
|
||
# Build a window that contains $now_min and is clamped to [0, 1439]
|
||
# so we never depend on negative bounds happening to compare correctly.
|
||
my $in_lo = $now_min >= 5 ? $now_min - 5 : 0;
|
||
my $in_hi = $now_min <= 1434 ? $now_min + 5 : 1439;
|
||
$uinfo = { 'allowhours' => [$in_lo, $in_hi] };
|
||
ok(miniserv::check_user_time('alice'), 'current time inside allowhours window → allowed');
|
||
|
||
# A fixed window strictly disjoint from $now_min and entirely within
|
||
# [0, 1439]. Pick the half-day opposite the current time: morning →
|
||
# evening window, afternoon/night → early-morning window. Either way
|
||
# the window cannot contain $now_min, and the bounds stay valid.
|
||
my ($out_lo, $out_hi) = $now_min < 720
|
||
? (1380, 1430) # 23:00–23:50
|
||
: (10, 60); # 00:10–01:00
|
||
$uinfo = { 'allowhours' => [$out_lo, $out_hi] };
|
||
ok(!miniserv::check_user_time('alice'),
|
||
'current time outside allowhours window → denied');
|
||
};
|
||
|
||
# check_user_ip — login allowed from current remote IP?
|
||
#
|
||
# Same shape as check_user_time: stub get_user_details, set $acptip and
|
||
# $localip (package globals that handle_request normally `local`-izes).
|
||
subtest 'check_user_ip' => sub {
|
||
no warnings qw(redefine once);
|
||
my $uinfo;
|
||
local *miniserv::get_user_details = sub { $uinfo };
|
||
local %miniserv::ip_match_cache = ();
|
||
local $miniserv::acptip = '1.2.3.4';
|
||
local $miniserv::localip = '5.6.7.8';
|
||
|
||
$uinfo = undef;
|
||
ok(miniserv::check_user_ip('alice'), 'unknown user → allowed');
|
||
|
||
$uinfo = { 'name' => 'alice' };
|
||
ok(miniserv::check_user_ip('alice'),
|
||
'no allow or deny list → allowed');
|
||
|
||
my $deny_match = '1.2.3.4';
|
||
my $deny_miss = '9.9.9.9';
|
||
my $allow_match = '1.2.3.4';
|
||
my $allow_miss = '9.9.9.9';
|
||
|
||
$uinfo = { 'name' => 'alice', 'deny' => [ $deny_match ] };
|
||
ok(!miniserv::check_user_ip('alice'), 'deny list matches remote → denied');
|
||
|
||
$uinfo = { 'name' => 'alice', 'deny' => [ $deny_miss ] };
|
||
ok(miniserv::check_user_ip('alice'), 'deny list does not match → allowed');
|
||
|
||
$uinfo = { 'name' => 'alice', 'allow' => [ $allow_match ] };
|
||
ok(miniserv::check_user_ip('alice'), 'allow list matches remote → allowed');
|
||
|
||
$uinfo = { 'name' => 'alice', 'allow' => [ $allow_miss ] };
|
||
ok(!miniserv::check_user_ip('alice'), 'allow list does not match → denied');
|
||
};
|
||
|
||
# is_group_member — primary-gid match OR membership in /etc/group
|
||
#
|
||
# We pin the contract using the current process's own primary group, which
|
||
# is guaranteed to exist on any system that runs the test suite.
|
||
subtest 'is_group_member' => sub {
|
||
my @pw = getpwuid($<);
|
||
plan skip_all => 'cannot resolve current user via getpwuid' if !@pw;
|
||
my $primary_gid = $pw[3];
|
||
my @gr = getgrgid($primary_gid);
|
||
plan skip_all => 'cannot resolve current primary gid via getgrgid' if !@gr;
|
||
my $primary_group = $gr[0];
|
||
|
||
# uinfo[3] == primary gid → match regardless of group's member list.
|
||
my $uinfo_match = ['test-user', 'x', 99999, $primary_gid];
|
||
ok(miniserv::is_group_member($uinfo_match, $primary_group),
|
||
'primary gid match → member');
|
||
|
||
# Nonexistent group → 0.
|
||
ok(!miniserv::is_group_member($uinfo_match,
|
||
'__definitely_not_a_real_group_xyzzy__'),
|
||
'nonexistent group → not a member');
|
||
|
||
# A user that's neither in the group's member list nor sharing its gid.
|
||
my $other_group;
|
||
my $other_gid;
|
||
setgrent();
|
||
while (my @g = getgrent()) {
|
||
next if $g[2] == $primary_gid;
|
||
# Skip groups our synthetic user happens to be "in"
|
||
next if $g[3] =~ /\bdefinitely-not-in-this-group-xyzzy\b/;
|
||
$other_group = $g[0];
|
||
$other_gid = $g[2];
|
||
last;
|
||
}
|
||
endgrent();
|
||
SKIP: {
|
||
skip 'no second group available on this system', 1 if !$other_group;
|
||
my $alien = ['definitely-not-in-this-group-xyzzy', 'x', 99999, 99999];
|
||
ok(!miniserv::is_group_member($alien, $other_group),
|
||
'gid mismatch + not in member list → not a member');
|
||
}
|
||
};
|
||
|
||
# matches_cron — combined range/step (the `1-10/2` branch is not covered above)
|
||
subtest 'matches_cron (range/step)' => sub {
|
||
ok( miniserv::matches_cron('2-10/2', 4, 0), 'inside range, divisible by step → match');
|
||
ok(!miniserv::matches_cron('2-10/2', 3, 0), 'inside range, indivisible → miss');
|
||
ok(!miniserv::matches_cron('2-10/2', 12, 0), 'outside range → miss');
|
||
ok( miniserv::matches_cron('0-30/15', 15, 0), 'step matches at boundary');
|
||
};
|
||
|
||
# indexof — duplicate / undef handling
|
||
subtest 'indexof (extras)' => sub {
|
||
# Duplicates: first hit wins.
|
||
is(miniserv::indexof('a', 'a', 'b', 'a'), 0,
|
||
'duplicate needle returns first index');
|
||
# Numeric needle compared with `eq` to a string element.
|
||
is(miniserv::indexof(1, '0', '1', '2'), 1,
|
||
'numeric needle matches stringwise');
|
||
};
|
||
|
||
# get_type — the regex is /\.([A-z0-9]+)$/ — `[A-z]` covers more than letters.
|
||
subtest 'get_type (extras)' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::mime = (HTML => 'text/html-upper');
|
||
# Extension lookup is case-sensitive (the hash key wins or loses literally).
|
||
is(miniserv::get_type('foo.HTML'), 'text/html-upper',
|
||
'extension hash lookup is case-sensitive');
|
||
is(miniserv::get_type('foo.html'), 'text/plain',
|
||
'differently-cased miss falls back to text/plain');
|
||
# Empty extension — pattern needs at least one char after the dot.
|
||
is(miniserv::get_type('foo.'), 'text/plain',
|
||
'empty extension falls through');
|
||
};
|
||
|
||
# is_mobile_useragent — config-driven `@mobile_agents` extension list
|
||
subtest 'is_mobile_useragent (config-driven extras)' => sub {
|
||
no warnings 'once';
|
||
local @miniserv::mobile_agents = ('MyCustomBrowser');
|
||
|
||
ok( miniserv::is_mobile_useragent('Foo MyCustomBrowser/1.0'),
|
||
'config-supplied substring matches');
|
||
ok(!miniserv::is_mobile_useragent('Foo OtherBrowser/1.0'),
|
||
'unrelated UA still not flagged');
|
||
# Text-mode browsers (Lynx, Links) are in the hard-coded prefix list.
|
||
ok(miniserv::is_mobile_useragent('Lynx/2.8.9rel.1'), 'Lynx prefix flagged');
|
||
ok(miniserv::is_mobile_useragent('Links (2.21; Linux)'), 'Links prefix flagged');
|
||
};
|
||
|
||
# urlize — high-bit / control-character behaviour
|
||
subtest 'urlize (extras)' => sub {
|
||
# Non-ASCII bytes — must be percent-encoded.
|
||
my $out = miniserv::urlize("\xc3\xa9"); # UTF-8 'é'
|
||
like($out, qr/^%[0-9A-Fa-f]{2}%[0-9A-Fa-f]{2}$/,
|
||
'high-bit UTF-8 bytes are percent-encoded');
|
||
# Control characters.
|
||
is(miniserv::urlize("\n"), '%0A', 'newline encoded');
|
||
is(miniserv::urlize("\t"), '%09', 'tab encoded');
|
||
};
|
||
|
||
# simplify_path — additional adversarial inputs
|
||
subtest 'simplify_path (extras)' => sub {
|
||
my $bogus;
|
||
# An empty string normalises to a bare slash.
|
||
is(miniserv::simplify_path('', $bogus), '/', 'empty string → /');
|
||
# A trailing slash is preserved? Run it and pin whatever the contract is.
|
||
is(miniserv::simplify_path('/foo/', $bogus), '/foo',
|
||
'trailing slash collapses');
|
||
# ".." mixed with concrete segments collapses correctly.
|
||
is(miniserv::simplify_path('/a/b/c/../../d', $bogus), '/a/d',
|
||
'multiple .. pop the right number of segments');
|
||
is($bogus, 0, '.. that stays in-bounds is not bogus');
|
||
};
|
||
|
||
# make_datestr — log timestamp format
|
||
subtest 'make_datestr' => sub {
|
||
no warnings 'once';
|
||
local @miniserv::month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
||
local $miniserv::timezone = '+0000';
|
||
|
||
my $d = miniserv::make_datestr();
|
||
# Format: DD/Mon/YYYY:HH:MM:SS +0000 (Apache combined-log shape).
|
||
like($d, qr{^\d{2}/(?:Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)/\d{4}:\d{2}:\d{2}:\d{2}\s\+0000$},
|
||
'datestr matches Apache combined-log shape');
|
||
};
|
||
|
||
# getenv — case-insensitive env var lookup
|
||
subtest 'getenv' => sub {
|
||
local %ENV = (FOO => 'upper', bar => 'lower');
|
||
is(miniserv::getenv('foo'), 'upper', 'lc lookup finds uc-set var');
|
||
is(miniserv::getenv('FOO'), 'upper', 'uc lookup finds uc-set var');
|
||
is(miniserv::getenv('BAR'), 'lower', 'uc lookup falls through to lc-set var');
|
||
is(miniserv::getenv('bar'), 'lower', 'lc lookup finds lc-set var');
|
||
is(miniserv::getenv('missing'), undef, 'missing var returns undef');
|
||
};
|
||
|
||
# should_gzip_file — content-type-class allow/deny
|
||
subtest 'should_gzip_file' => sub {
|
||
ok( miniserv::should_gzip_file('foo.html'), 'html → gzip ok');
|
||
ok( miniserv::should_gzip_file('foo.css'), 'css → gzip ok');
|
||
ok( miniserv::should_gzip_file('foo.js'), 'js → gzip ok');
|
||
ok( miniserv::should_gzip_file('noext'), 'no extension → gzip ok');
|
||
ok(!miniserv::should_gzip_file('foo.png'), 'png skipped');
|
||
ok(!miniserv::should_gzip_file('foo.jpg'), 'jpg skipped');
|
||
ok(!miniserv::should_gzip_file('foo.JPEG'), 'JPEG (uppercase) skipped');
|
||
ok(!miniserv::should_gzip_file('foo.tif'), 'tif skipped');
|
||
};
|
||
|
||
# get_expires_time — per-path expiry table with default fallback
|
||
subtest 'get_expires_time' => sub {
|
||
no warnings 'once';
|
||
local @miniserv::expires_paths = (
|
||
[ '\.css$', 3600 ],
|
||
[ '\.js$', 86400 ],
|
||
);
|
||
local %miniserv::config = ('expires' => 60);
|
||
|
||
is(miniserv::get_expires_time('/x.css'), 3600,
|
||
'matching regexp → its expiry');
|
||
is(miniserv::get_expires_time('/x.js'), 86400,
|
||
'second matching regexp → its expiry');
|
||
is(miniserv::get_expires_time('/x.html'), 60,
|
||
'no match → falls back to config{expires}');
|
||
# Case-insensitivity is part of the contract (path !~ /$re/i).
|
||
is(miniserv::get_expires_time('/X.CSS'), 3600,
|
||
'regexp match is case-insensitive');
|
||
};
|
||
|
||
# network_to_address — inet_ntoa / inet_ntop dispatch
|
||
subtest 'network_to_address' => sub {
|
||
no warnings 'once';
|
||
|
||
# 4-byte input always uses inet_ntoa, regardless of $use_ipv6.
|
||
{
|
||
local $miniserv::use_ipv6 = 0;
|
||
is(miniserv::network_to_address(pack("CCCC", 1, 2, 3, 4)),
|
||
'1.2.3.4', 'IPv4 bytes formatted via inet_ntoa');
|
||
}
|
||
|
||
# 16-byte input with IPv6 enabled → inet_ntop. miniserv.pl normally
|
||
# imports inet_ntop via Socket6 (loaded under `eval` at startup); in the
|
||
# module-load path it may not be bound, so glob it in for the test.
|
||
SKIP: {
|
||
eval { require Socket; Socket->import(qw(AF_INET6 inet_ntop inet_pton)); };
|
||
skip 'Socket lacks IPv6 helpers', 1 if $@;
|
||
no warnings 'redefine';
|
||
local *miniserv::inet_ntop = \&Socket::inet_ntop;
|
||
local $miniserv::use_ipv6 = 1;
|
||
my $packed = Socket::inet_pton(Socket::AF_INET6(), '::1');
|
||
is(miniserv::network_to_address($packed), '::1',
|
||
'IPv6 bytes formatted via inet_ntop');
|
||
}
|
||
};
|
||
|
||
# to_ipaddress — pattern shortcuts that skip DNS
|
||
subtest 'to_ipaddress (pattern shortcuts)' => sub {
|
||
# IPv4 literal: returned verbatim.
|
||
is(miniserv::to_ipaddress('1.2.3.4'), '1.2.3.4',
|
||
'IPv4 literal short-circuits');
|
||
# Hostname-glob pattern: returned verbatim.
|
||
is(miniserv::to_ipaddress('*.example.com'), '*.example.com',
|
||
'wildcard hostname pattern short-circuits');
|
||
# 'LOCAL' literal: returned verbatim.
|
||
is(miniserv::to_ipaddress('LOCAL'), 'LOCAL',
|
||
'LOCAL keyword short-circuits');
|
||
# CIDR pattern: returned verbatim.
|
||
is(miniserv::to_ipaddress('10.0.0.0/8'), '10.0.0.0/8',
|
||
'CIDR pattern short-circuits');
|
||
};
|
||
|
||
# ip_match — additional branches: LOCAL, IPv6 exact, IPv6 CIDR, hostname-glob miss
|
||
subtest 'ip_match (extra branches)' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::ip_match_cache = ();
|
||
|
||
# LOCAL keyword expands to a class-derived prefix of the local IP.
|
||
my $local_rule = 'LOCAL';
|
||
ok( miniserv::ip_match('10.1.2.3', '10.9.9.9', $local_rule),
|
||
'LOCAL: class-A remote in same /8 as local matches');
|
||
ok(!miniserv::ip_match('11.1.2.3', '10.9.9.9', $local_rule),
|
||
'LOCAL: different /8 does not match');
|
||
|
||
# 192.x.x.x is class C → /24 comparison.
|
||
my $local_rule2 = 'LOCAL';
|
||
ok( miniserv::ip_match('192.168.1.5', '192.168.1.1', $local_rule2),
|
||
'LOCAL: class-C remote in same /24 as local matches');
|
||
ok(!miniserv::ip_match('192.168.2.5', '192.168.1.1', $local_rule2),
|
||
'LOCAL: different /24 does not match');
|
||
|
||
# IPv6 exact match.
|
||
my $v6_exact = '2001:db8::1';
|
||
ok( miniserv::ip_match('2001:db8::1', '::1', $v6_exact),
|
||
'IPv6 exact match (canonicalized)');
|
||
ok( miniserv::ip_match('2001:DB8::1', '::1', $v6_exact),
|
||
'IPv6 exact match is case-insensitive after canonicalization');
|
||
|
||
# IPv6 CIDR — /32 covers the leading 4 bytes (2001:0db8:...).
|
||
my $v6_cidr = '2001:db8::/32';
|
||
ok( miniserv::ip_match('2001:db8:1234::5', '::1', $v6_cidr),
|
||
'IPv6 CIDR /32 covers a host inside the prefix');
|
||
ok(!miniserv::ip_match('2002:db8:1234::5', '::1', $v6_cidr),
|
||
'IPv6 CIDR /32 does not cover a host outside the prefix');
|
||
};
|
||
|
||
# users_match — group (@-prefix) branch
|
||
subtest 'users_match (group branch)' => sub {
|
||
# Pick the current user's primary group, guaranteed to resolve.
|
||
my @pw = getpwuid($<);
|
||
plan skip_all => 'cannot resolve current user via getpwuid' if !@pw;
|
||
my $gid = $pw[3];
|
||
my @gr = getgrgid($gid);
|
||
plan skip_all => 'cannot resolve primary gid via getgrgid' if !@gr;
|
||
my $group = $gr[0];
|
||
|
||
# uinfo[3] == primary gid → is_group_member returns true → users_match matches.
|
||
my $uinfo = ['someuser', 'x', 99999, $gid];
|
||
ok( miniserv::users_match($uinfo, '@'.$group),
|
||
'@<group> matches when uinfo primary gid matches');
|
||
ok(!miniserv::users_match($uinfo,
|
||
'@__definitely_not_a_real_group_xyzzy__'),
|
||
'@<nonexistent-group> does not match');
|
||
};
|
||
|
||
# read_config_file — KEY=VAL parser used at startup
|
||
subtest 'read_config_file' => sub {
|
||
require File::Temp;
|
||
my ($fh, $path) = File::Temp::tempfile(UNLINK => 1);
|
||
print $fh <<'EOF';
|
||
# this is a comment
|
||
|
||
key1 = value1
|
||
key2=value2
|
||
key3 = has spaces
|
||
empty=
|
||
EOF
|
||
close($fh);
|
||
|
||
my %got = miniserv::read_config_file($path);
|
||
is($got{key1}, 'value1', 'leading/trailing whitespace trimmed');
|
||
is($got{key2}, 'value2', 'tight key=val parsed');
|
||
is($got{key3}, 'has spaces', 'interior whitespace preserved');
|
||
is($got{empty}, '', 'empty value yields empty string');
|
||
ok(!exists $got{'# this is a comment'}, 'comment lines skipped');
|
||
};
|
||
|
||
# read_any_file — basic file reader; returns undef on open failure
|
||
subtest 'read_any_file' => sub {
|
||
require File::Temp;
|
||
my ($fh, $path) = File::Temp::tempfile(UNLINK => 1);
|
||
print $fh "line1\nline2\n";
|
||
close($fh);
|
||
|
||
is(miniserv::read_any_file($path), "line1\nline2\n",
|
||
'returns the entire file contents');
|
||
is(miniserv::read_any_file('/definitely/not/a/real/path/xyzzy'), undef,
|
||
'open failure returns undef');
|
||
};
|
||
|
||
# read_mime_types — populates %mime from file + addtype_* config
|
||
subtest 'read_mime_types' => sub {
|
||
no warnings 'once';
|
||
require File::Temp;
|
||
my ($fh, $path) = File::Temp::tempfile(UNLINK => 1);
|
||
print $fh <<'EOF';
|
||
# comment line
|
||
text/html html htm
|
||
image/png png
|
||
EOF
|
||
close($fh);
|
||
|
||
local %miniserv::config = (
|
||
'mimetypes' => $path,
|
||
'addtype_custom' => 'application/x-custom',
|
||
);
|
||
local %miniserv::mime = ();
|
||
|
||
miniserv::read_mime_types();
|
||
is($miniserv::mime{html}, 'text/html', 'first extension from file mapped');
|
||
is($miniserv::mime{htm}, 'text/html', 'second extension on same line mapped');
|
||
is($miniserv::mime{png}, 'image/png', 'second line mapped');
|
||
is($miniserv::mime{custom}, 'application/x-custom', 'addtype_* config overrides file');
|
||
};
|
||
|
||
# parse_websockets_config — turns websockets_<path> config lines into structs
|
||
subtest 'parse_websockets_config' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::config = (
|
||
'websockets_/chat' => 'host=back.example.com port=9000 proto=ws',
|
||
'unrelated_key' => 'ignored',
|
||
);
|
||
local @miniserv::websocket_paths = ();
|
||
|
||
miniserv::parse_websockets_config();
|
||
is(scalar @miniserv::websocket_paths, 1, 'one websocket entry produced');
|
||
my $ws = $miniserv::websocket_paths[0];
|
||
is($ws->{path}, '/chat', 'path captured from key suffix');
|
||
is($ws->{host}, 'back.example.com', 'host kv parsed');
|
||
is($ws->{port}, '9000', 'port kv parsed');
|
||
is($ws->{proto}, 'ws', 'proto kv parsed');
|
||
};
|
||
|
||
# get_user_details — local-files branch (skips the userdb code path entirely)
|
||
subtest 'get_user_details (local files)' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::config = (); # no userdb → file path only
|
||
local %miniserv::users = ('alice' => 'hashedpass');
|
||
local %miniserv::certs = ('alice' => 'CN=Alice');
|
||
local %miniserv::allow = ('alice' => ['1.2.3.4']);
|
||
local %miniserv::deny = ('alice' => ['9.9.9.9']);
|
||
local %miniserv::allowdays = ('alice' => [0, 1, 2]);
|
||
local %miniserv::allowhours = ('alice' => [540, 1020]);
|
||
local %miniserv::lastchanges = ('alice' => '1700000000');
|
||
local %miniserv::nochange = ('alice' => 1);
|
||
local %miniserv::temppass = ('alice' => 0);
|
||
local %miniserv::twofactor = ('alice' => {
|
||
'provider' => 'totp', 'id' => 'aliceid', 'apikey' => 'secret' });
|
||
|
||
my $u = miniserv::get_user_details('alice');
|
||
is(ref($u), 'HASH', 'returns a hashref');
|
||
is($u->{name}, 'alice', 'name field');
|
||
is($u->{pass}, 'hashedpass', 'pass field comes from %users');
|
||
is($u->{certs}, 'CN=Alice', 'certs field');
|
||
is_deeply($u->{allow}, ['1.2.3.4'], 'allow list');
|
||
is_deeply($u->{deny}, ['9.9.9.9'], 'deny list');
|
||
is($u->{twofactor_provider}, 'totp', 'twofactor provider lifted');
|
||
is($u->{twofactor_id}, 'aliceid', 'twofactor id lifted');
|
||
is($u->{twofactor_apikey}, 'secret', 'twofactor apikey lifted');
|
||
|
||
is(miniserv::get_user_details('nobody'), undef,
|
||
'unknown user with no userdb returns undef');
|
||
|
||
# origusername falls back to username for twofactor lookup.
|
||
local %miniserv::twofactor = (
|
||
'bob_orig' => { 'provider' => 'duo', 'id' => 'bid', 'apikey' => 'bk' });
|
||
local %miniserv::users = ('bob_local' => 'hash');
|
||
my $u2 = miniserv::get_user_details('bob_local', 'bob_orig');
|
||
is($u2->{twofactor_provider}, 'duo',
|
||
'twofactor looked up by origusername when present');
|
||
};
|
||
|
||
# find_user_by_cert — local-files branch (matches against %certs)
|
||
subtest 'find_user_by_cert (local files)' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::config = (); # no userdb
|
||
local %miniserv::certs = (
|
||
'alice' => 'CN=Alice,Email=alice@example.com',
|
||
'bob' => 'CN=Bob,emailAddress=bob@example.com',
|
||
);
|
||
|
||
is(miniserv::find_user_by_cert('CN=Alice,Email=alice@example.com'),
|
||
'alice', 'exact match returns username');
|
||
# emailAddress=/Email= are swapped before comparison.
|
||
is(miniserv::find_user_by_cert('CN=Alice,emailAddress=alice@example.com'),
|
||
'alice', 'Email/emailAddress form aliasing matches');
|
||
is(miniserv::find_user_by_cert('CN=Bob,Email=bob@example.com'),
|
||
'bob', 'reverse aliasing also matches');
|
||
is(miniserv::find_user_by_cert('CN=Nobody'), undef,
|
||
'unknown peer name returns undef');
|
||
};
|
||
|
||
# get_logout_time — per-user / per-group / default rules
|
||
subtest 'get_logout_time' => sub {
|
||
no warnings 'once';
|
||
local %miniserv::logout_time_cache = ();
|
||
|
||
# Username branch beats the default.
|
||
local @miniserv::logouttimes = (
|
||
[ 'alice', 30 ],
|
||
[ undef, 10 ],
|
||
);
|
||
is(miniserv::get_logout_time('alice', 'sid1'), 30,
|
||
'username-specific rule wins');
|
||
is(miniserv::get_logout_time('alice', 'sid1'), 30,
|
||
'second call returns cached value');
|
||
|
||
is(miniserv::get_logout_time('charlie', 'sid2'), 10,
|
||
'user with no specific rule falls through to default (undef key)');
|
||
|
||
# Group rule (@-prefix) — requires that the user resolves via getpwnam,
|
||
# so use the current process user.
|
||
my @pw = getpwuid($<);
|
||
SKIP: {
|
||
skip 'cannot resolve current user', 1 if !@pw;
|
||
my @gr = getgrgid($pw[3]);
|
||
skip 'cannot resolve primary group', 1 if !@gr;
|
||
local %miniserv::logout_time_cache = ();
|
||
local @miniserv::logouttimes = (
|
||
[ '@'.$gr[0], 99 ],
|
||
[ undef, 10 ],
|
||
);
|
||
is(miniserv::get_logout_time($pw[0], 'sid3'), 99,
|
||
'@group rule matches via primary gid');
|
||
}
|
||
};
|
||
|
||
# build_config_mappings — turns flat %config keys into structured globals
|
||
subtest 'build_config_mappings' => sub {
|
||
no warnings qw(once redefine);
|
||
# Stub open_debug_to_log — it touches DEBUG (an unopened fh in tests).
|
||
local *miniserv::open_debug_to_log = sub { };
|
||
local *miniserv::to_ipaddress = sub { return @_; };
|
||
|
||
local %miniserv::config = (
|
||
'anonymous' => '/pub=guest /api=apiuser',
|
||
'ipaccess' => '/admin=10.0.0.0/8',
|
||
'unauth' => '^/public/ ^/robots.txt$',
|
||
'unauthcgi' => '^/login.cgi$',
|
||
'redirect' => '/old=/new',
|
||
'strip_prefix' => '/virt',
|
||
'deny' => '9.9.9.9 8.8.8.8',
|
||
'allow' => '1.2.3.4',
|
||
'allowusers' => 'alice bob',
|
||
'unixauth' => 'admin=root *=apache',
|
||
'sessiononly' => '/api /webhooks',
|
||
'logouttimes' => 'alice=15 @wheel=60',
|
||
'logouttime' => 5,
|
||
'davpaths' => '/dav1 /dav2',
|
||
'dav_users' => 'eve',
|
||
'mobile_agents' => "Foo\tBar",
|
||
'mobile_prefixes' => 'XYZ ABC',
|
||
'expires_paths' => "\\.css\$=3600\t\\.js\$=86400",
|
||
'alwaysresolve' => 1, # keep deny/allow as-is (no DNS)
|
||
);
|
||
|
||
# Reset every output global.
|
||
local %miniserv::anonymous = ();
|
||
local %miniserv::ipaccess = ();
|
||
local @miniserv::unauth = ();
|
||
local @miniserv::unauthcgi = ();
|
||
local %miniserv::redirect = ();
|
||
local @miniserv::strip_prefix = ();
|
||
local @miniserv::deny = ();
|
||
local @miniserv::allow = ();
|
||
local @miniserv::allowusers = ();
|
||
local @miniserv::denyusers = ();
|
||
local %miniserv::unixauth = ();
|
||
local %miniserv::sessiononly = ();
|
||
local @miniserv::logouttimes = ();
|
||
local @miniserv::davpaths = ();
|
||
local @miniserv::davusers = ();
|
||
local @miniserv::mobile_agents = ();
|
||
local @miniserv::mobile_prefixes = ();
|
||
local @miniserv::expires_paths = ();
|
||
local %miniserv::sudocache = ();
|
||
local %miniserv::cert_names_cache = ();
|
||
|
||
miniserv::build_config_mappings();
|
||
|
||
is($miniserv::anonymous{'/pub'}, 'guest', 'anonymous map parsed');
|
||
is($miniserv::ipaccess{'/admin'}, '10.0.0.0/8', 'ipaccess map parsed');
|
||
is_deeply(\@miniserv::unauth, ['^/public/', '^/robots.txt$'], 'unauth list parsed');
|
||
is_deeply(\@miniserv::unauthcgi, ['^/login.cgi$'], 'unauthcgi list parsed');
|
||
is($miniserv::redirect{'/old'}, '/new', 'redirect map parsed');
|
||
is_deeply(\@miniserv::strip_prefix, ['/virt'], 'strip_prefix parsed');
|
||
is_deeply(\@miniserv::allowusers, ['alice', 'bob'], 'allowusers parsed');
|
||
is(scalar @miniserv::denyusers, 0,
|
||
'denyusers stays empty when allowusers is set (mutually exclusive)');
|
||
is($miniserv::unixauth{admin}, 'root', 'specific unixauth parsed');
|
||
is($miniserv::unixauth{'*'}, 'apache', 'default unixauth parsed');
|
||
ok($miniserv::sessiononly{'/api'}, 'sessiononly entry set');
|
||
is_deeply(\@miniserv::davpaths, ['/dav1', '/dav2'], 'davpaths parsed');
|
||
is_deeply(\@miniserv::davusers, ['eve'], 'davusers parsed');
|
||
is_deeply(\@miniserv::mobile_agents, ['Foo', 'Bar'],
|
||
'mobile_agents tab-split');
|
||
|
||
# logouttimes: configured rules + an always-match default appended.
|
||
is(scalar @miniserv::logouttimes, 3, 'two configured + one default');
|
||
is($miniserv::logouttimes[-1][0], undef, 'last entry is the default rule');
|
||
is($miniserv::logouttimes[-1][1], 5, 'default uses logouttime');
|
||
|
||
# expires_paths: each tab-separated entry becomes [regex, secs].
|
||
is(scalar @miniserv::expires_paths, 2, 'two expires entries');
|
||
is_deeply($miniserv::expires_paths[0], ['\.css$', '3600'],
|
||
'first expires entry split on =');
|
||
};
|
||
|
||
# lock_user_password — local-file branch rewrites the users file in place
|
||
subtest 'lock_user_password (local file)' => sub {
|
||
no warnings qw(once redefine);
|
||
require File::Temp;
|
||
my ($fh, $path) = File::Temp::tempfile(UNLINK => 1);
|
||
# Standard 5-field users line (user:pass:lastchange:certs:opts...).
|
||
print $fh "alice:hashedpass:0::\n";
|
||
print $fh "bob:bobhash:0::\n";
|
||
close($fh);
|
||
|
||
local %miniserv::config = ('userfile' => $path);
|
||
local %miniserv::users = (
|
||
'alice' => 'hashedpass',
|
||
'bob' => 'bobhash',
|
||
);
|
||
# get_user_details would normally do %users → hashref; stub it.
|
||
local *miniserv::get_user_details = sub {
|
||
my ($u) = @_;
|
||
return undef if !exists $miniserv::users{$u};
|
||
return { 'name' => $u, 'pass' => $miniserv::users{$u} };
|
||
};
|
||
|
||
is(miniserv::lock_user_password('nobody'), -1,
|
||
'unknown user returns -1');
|
||
|
||
is(miniserv::lock_user_password('alice'), 0, 'lock succeeds');
|
||
is($miniserv::users{alice}, '!hashedpass',
|
||
'in-memory pass is prefixed with !');
|
||
|
||
# File on disk reflects the change.
|
||
open(my $rh, '<', $path) or die "reopen: $!";
|
||
my $content = do { local $/; <$rh> };
|
||
close($rh);
|
||
like ($content, qr/^alice:!hashedpass:/m, 'alice line rewritten with !');
|
||
like ($content, qr/^bob:bobhash:/m, 'bob line untouched');
|
||
|
||
# Locking an already-locked user is a no-op (returns 0 but no double-!).
|
||
is(miniserv::lock_user_password('alice'), 0,
|
||
'already-locked user → 0 (no-op)');
|
||
is($miniserv::users{alice}, '!hashedpass',
|
||
'no double-bang prefix on second lock');
|
||
};
|
||
|
||
done_testing();
|