mirror of
https://github.com/webmin/webmin.git
synced 2026-06-22 12:10:28 +01:00
xmlrpc.cgi strict, warnings, critic, tests, and security audit
This commit is contained in:
Joe Cooper
216
t/xmlrpc.t
Normal file
216
t/xmlrpc.t
Normal file
@@ -0,0 +1,216 @@
|
||||
#!/usr/bin/perl
|
||||
# Unit tests for xmlrpc.cgi helper subs.
|
||||
#
|
||||
# xmlrpc.cgi is loaded as a module; its top-level body (ACL check, reading
|
||||
# the request, dispatching the call, emitting the response) is skipped by
|
||||
# the `unless (caller) { ... }` guard, so requiring it only defines the
|
||||
# subs plus loads WebminCore.
|
||||
#
|
||||
# The four subs under test are the XML <-> Perl marshalling layer:
|
||||
# encode_xml_value - Perl scalar/hashref/arrayref -> XML-RPC <value> body
|
||||
# parse_xml_value - parsed XML <value> node -> Perl scalar/ref
|
||||
# find_xmls - recursive element search over an XML::Parser tree
|
||||
# make_error_xml - faultCode/faultString -> <methodResponse> fault doc
|
||||
#
|
||||
# Assertions target the contract (type selection, round-trip identity,
|
||||
# structural balance, escaping), not exact whitespace or attribute order.
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Test::More;
|
||||
use File::Basename qw(dirname);
|
||||
use File::Spec;
|
||||
|
||||
# WebminCore loads web-lib.pl / ui-lib.pl with relative `do`, so the repo
|
||||
# root must be the cwd (the script's BEGIN block adds "." to @INC).
|
||||
my $root = File::Spec->rel2abs(
|
||||
File::Spec->catdir(dirname(__FILE__), '..'));
|
||||
chdir($root) or die "chdir $root: $!";
|
||||
|
||||
my $script = File::Spec->catfile($root, 'xmlrpc.cgi');
|
||||
require $script;
|
||||
|
||||
# XML::Parser is only needed to build the parsed-tree inputs for
|
||||
# parse_xml_value and the round-trip tests. Probe for it once.
|
||||
my $have_parser = eval { require XML::Parser; 1 };
|
||||
|
||||
# Build the parsed-tree node that parse_xml_value expects from an
|
||||
# encode_xml_value body: wrap it in <value>...</value> and parse. The root
|
||||
# node XML::Parser returns is itself a [name, content] pair, exactly the
|
||||
# shape find_xmls walks.
|
||||
sub value_tree {
|
||||
my ($body) = @_;
|
||||
return XML::Parser->new('Style' => 'Tree')
|
||||
->parse("<value>$body</value>");
|
||||
}
|
||||
|
||||
# encode_xml_value - type selection from the Perl side
|
||||
subtest 'encode_xml_value type selection' => sub {
|
||||
# Integers (with and without sign).
|
||||
is(encode_xml_value(5), "<int>5</int>\n", 'positive int');
|
||||
is(encode_xml_value(-3), "<int>-3</int>\n", 'negative int');
|
||||
is(encode_xml_value(0), "<int>0</int>\n", 'zero is an int');
|
||||
|
||||
# Doubles.
|
||||
like(encode_xml_value('3.14'), qr{^<double>3\.14</double>\s*$}, 'decimal -> double');
|
||||
like(encode_xml_value('-0.5'), qr{^<double>-0\.5</double>\s*$}, 'signed decimal -> double');
|
||||
|
||||
# Plain strings.
|
||||
like(encode_xml_value('hello'), qr{^<string>hello</string>\s*$}, 'word -> string');
|
||||
like(encode_xml_value(''), qr{^<string></string>\s*$}, 'empty string -> empty <string>');
|
||||
|
||||
# A value with control characters cannot live in a <string> (the
|
||||
# printable-range regex fails), so it must fall through to base64.
|
||||
like(encode_xml_value("a\tb\n"), qr{^<base64>.*</base64>\s*$}s,
|
||||
'control chars force base64 encoding');
|
||||
};
|
||||
|
||||
subtest 'encode_xml_value escapes markup' => sub {
|
||||
my $out = encode_xml_value('<b>&"x"</b>');
|
||||
unlike($out, qr/<b>/, 'literal markup does not survive in a string value');
|
||||
like($out, qr/&(?:amp|lt|gt|quot|#3[0-9]|#6[0-9]);/, 'special chars HTML-escaped');
|
||||
|
||||
# Struct member names are escaped too.
|
||||
my $s = encode_xml_value({ '<k>' => 'v' });
|
||||
unlike($s, qr/<name><k></, 'struct member name is escaped');
|
||||
};
|
||||
|
||||
subtest 'encode_xml_value nested structures' => sub {
|
||||
my $out = encode_xml_value({ list => [1, 2], name => 'bob' });
|
||||
|
||||
# Structural balance of the emitted markup.
|
||||
for my $tag (qw(struct member name value)) {
|
||||
my $open = () = $out =~ /<$tag\b[^>]*>/g;
|
||||
my $close = () = $out =~ /<\/$tag>/g;
|
||||
is($open, $close, "<$tag> tags balanced");
|
||||
}
|
||||
like($out, qr{<array>.*<data>.*</data>.*</array>}s, 'nested array rendered inside struct');
|
||||
|
||||
# A flat array of mixed scalar types: one <value> wrapper each.
|
||||
my $arr = encode_xml_value([5, 'hi', 'x']);
|
||||
like($arr, qr{^<array>\s*<data>}s, 'array opens with <data>');
|
||||
my $vopen = () = $arr =~ /<value>/g;
|
||||
my $vclose = () = $arr =~ /<\/value>/g;
|
||||
is($vopen, $vclose, '<value> wrappers balanced in array');
|
||||
is($vopen, 3, 'one <value> per scalar array element');
|
||||
};
|
||||
|
||||
# find_xmls - recursive element search over a hand-built tree. The tree
|
||||
# format is XML::Parser's: a node is [name, [ {attrs}, childname, childcontent, ...]].
|
||||
subtest 'find_xmls' => sub {
|
||||
# <a><b>x</b><c><b>y</b></c></a>
|
||||
my $tree = [ 'a', [ {},
|
||||
'b', [ {}, 0, 'x' ],
|
||||
'c', [ {}, 'b', [ {}, 0, 'y' ] ],
|
||||
] ];
|
||||
|
||||
my @b = find_xmls('b', $tree);
|
||||
is(scalar @b, 2, 'finds both <b> elements at any depth');
|
||||
is($b[0]->[0], 'b', 'returned node carries its tag name');
|
||||
is($b[0]->[1]->[2], 'x', 'first <b> text reachable at content index 2');
|
||||
|
||||
# Depth limiting: depth 1 only looks at direct children, so the
|
||||
# nested <b> inside <c> is not reached.
|
||||
my @shallow = find_xmls('b', $tree, 1);
|
||||
is(scalar @shallow, 1, 'depth=1 finds only the direct-child <b>');
|
||||
|
||||
# Name-list form matches any of several tags (case-insensitively,
|
||||
# via indexoflc). Search stops descending at a match, so the <b>
|
||||
# nested inside the matched <c> is not also returned.
|
||||
my @bc = find_xmls([ 'c', 'b' ], $tree);
|
||||
is(scalar @bc, 2, 'name-list matches the outer <b> and the <c>, not inside a match');
|
||||
|
||||
# A name that is not present returns the empty list.
|
||||
is_deeply([ find_xmls('zzz', $tree) ], [], 'absent name -> empty list');
|
||||
|
||||
# The root element itself can match.
|
||||
my @self = find_xmls('a', $tree);
|
||||
is(scalar @self, 1, 'root element matches its own name');
|
||||
};
|
||||
|
||||
# parse_xml_value - drive the real parser so the tree shape is authentic.
|
||||
subtest 'parse_xml_value' => sub {
|
||||
plan skip_all => 'XML::Parser not installed' if !$have_parser;
|
||||
|
||||
is(parse_xml_value(value_tree('<int>42</int>')), 42, 'int parsed');
|
||||
is(parse_xml_value(value_tree('<i4>7</i4>')), 7, 'i4 alias parsed');
|
||||
is(parse_xml_value(value_tree('<boolean>1</boolean>')),1, 'boolean parsed');
|
||||
is(parse_xml_value(value_tree('<double>2.5</double>')),'2.5', 'double parsed');
|
||||
is(parse_xml_value(value_tree('<string>hi</string>')), 'hi', 'string parsed');
|
||||
|
||||
# base64 is decoded back to its raw bytes.
|
||||
my $b64 = encode_base64("ab\x00cd");
|
||||
chomp($b64);
|
||||
is(parse_xml_value(value_tree("<base64>$b64</base64>")), "ab\x00cd",
|
||||
'base64 decoded to raw bytes');
|
||||
|
||||
# struct -> hashref.
|
||||
my $h = parse_xml_value(value_tree(
|
||||
'<struct><member><name>k</name><value><int>1</int></value></member></struct>'));
|
||||
is(ref($h), 'HASH', 'struct -> hashref');
|
||||
is($h->{k}, 1, 'struct member value parsed');
|
||||
|
||||
# array -> arrayref.
|
||||
my $a = parse_xml_value(value_tree(
|
||||
'<array><data><value><int>1</int></value><value><string>x</string></value></data></array>'));
|
||||
is(ref($a), 'ARRAY', 'array -> arrayref');
|
||||
is_deeply($a, [1, 'x'], 'array elements parsed in order');
|
||||
};
|
||||
|
||||
# Round-trip: encode_xml_value then parse_xml_value should reproduce the
|
||||
# original Perl value. This is the core marshalling contract.
|
||||
subtest 'encode/parse round-trip' => sub {
|
||||
plan skip_all => 'XML::Parser not installed' if !$have_parser;
|
||||
|
||||
my %scalars = (
|
||||
'positive int' => 5,
|
||||
'negative int' => -42,
|
||||
'zero' => 0,
|
||||
'simple string' => 'hello world',
|
||||
);
|
||||
for my $name (sort keys %scalars) {
|
||||
my $v = $scalars{$name};
|
||||
is(parse_xml_value(value_tree(encode_xml_value($v))), $v,
|
||||
"round-trip: $name");
|
||||
}
|
||||
|
||||
# Nested struct + array survives a round-trip structurally.
|
||||
my $complex = { name => 'bob', nums => [1, 2, 3], inner => { x => 'y' } };
|
||||
is_deeply(parse_xml_value(value_tree(encode_xml_value($complex))),
|
||||
{ name => 'bob', nums => [1, 2, 3], inner => { x => 'y' } },
|
||||
'round-trip: nested struct and array');
|
||||
|
||||
# Binary data routes through base64 and comes back byte-identical.
|
||||
my $bin = join('', map { chr } 0 .. 31);
|
||||
is(parse_xml_value(value_tree(encode_xml_value($bin))), $bin,
|
||||
'round-trip: binary payload via base64');
|
||||
};
|
||||
|
||||
# make_error_xml - fault document shape, and that each call is independent
|
||||
# (the body buffer is a my-scoped var, not an accumulating package global).
|
||||
subtest 'make_error_xml' => sub {
|
||||
my $err = make_error_xml(7, 'boom');
|
||||
|
||||
like($err, qr{<methodResponse>.*<fault>.*</fault>.*</methodResponse>}s,
|
||||
'fault wrapped in methodResponse');
|
||||
like($err, qr{<name>faultCode</name>}, 'carries faultCode member');
|
||||
like($err, qr{<name>faultString</name>}, 'carries faultString member');
|
||||
like($err, qr{<int>7</int>}, 'numeric code encoded as int');
|
||||
like($err, qr{boom}, 'message text present');
|
||||
|
||||
# Two successive calls must not accumulate: each returns exactly one
|
||||
# methodResponse. (A package-global buffer would double the second.)
|
||||
my $first = make_error_xml(1, 'one');
|
||||
my $second = make_error_xml(2, 'two');
|
||||
my $count = () = $second =~ /<methodResponse>/g;
|
||||
is($count, 1, 'each call returns a single, fresh fault document');
|
||||
unlike($second, qr/one/, 'second call does not contain first message');
|
||||
|
||||
# A faultString with newlines still produces a single balanced doc.
|
||||
my $multiline = make_error_xml(9, "line1\nline2");
|
||||
my $open = () = $multiline =~ /<methodResponse>/g;
|
||||
my $close = () = $multiline =~ /<\/methodResponse>/g;
|
||||
is($open, $close, 'methodResponse balanced with multiline message');
|
||||
};
|
||||
|
||||
done_testing();
|
||||
75
xmlrpc.cgi
75
xmlrpc.cgi
@@ -1,6 +1,18 @@
|
||||
#!/usr/local/bin/perl
|
||||
# Handles xml-rpc requests from arbitrary clients. Each is a call to a
|
||||
# function in a Webmin module.
|
||||
# function in a Webmin module.
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our ($command_line, $no_acl_check, $force_lang, $trust_unknown_referers);
|
||||
|
||||
BEGIN { push(@INC, "."); };
|
||||
use WebminCore;
|
||||
use POSIX;
|
||||
use Socket;
|
||||
|
||||
unless (caller) {
|
||||
|
||||
if (!$ENV{'GATEWAY_INTERFACE'}) {
|
||||
# Command-line mode
|
||||
@@ -10,15 +22,11 @@ if (!$ENV{'GATEWAY_INTERFACE'}) {
|
||||
if ($0 =~ /^(.*\/)[^\/]+$/) {
|
||||
chdir($1);
|
||||
}
|
||||
chop($pwd = `pwd`);
|
||||
chomp(my $pwd = `pwd`);
|
||||
$0 = "$pwd/xmlrpc.pl";
|
||||
$command_line = 1;
|
||||
$> == 0 || die "xmlrpc.cgi must be run as root";
|
||||
}
|
||||
BEGIN { push(@INC, "."); };
|
||||
use WebminCore;
|
||||
use POSIX;
|
||||
use Socket;
|
||||
|
||||
$main::allow_rpc_only = 1;
|
||||
$force_lang = $default_lang;
|
||||
@@ -26,24 +34,19 @@ $trust_unknown_referers = 2; # Only trust if referer was not set
|
||||
&init_config();
|
||||
$main::error_must_die = 1;
|
||||
|
||||
# Can this user make remote calls?
|
||||
if (!$command_line) {
|
||||
%access = &get_module_acl();
|
||||
if ($access{'rpc'} == 0 || $access{'rpc'} == 2 &&
|
||||
$base_remote_user ne 'admin' && $base_remote_user ne 'root' &&
|
||||
$base_remote_user ne 'sysadm') {
|
||||
&error_exit(1, "Invalid user for RPC");
|
||||
}
|
||||
# Can this user make remote calls? webmin_user_can_rpc() centralises the
|
||||
# policy (rpc=0 none, 1 all, 2 admin-only, 3 RPC-only) and is fail-closed
|
||||
# when the ACL is unset.
|
||||
if (!$command_line && !&webmin_user_can_rpc()) {
|
||||
&error_exit(1, "Invalid user for RPC");
|
||||
}
|
||||
|
||||
# Load the XML parser module
|
||||
eval "use XML::Parser";
|
||||
if ($@) {
|
||||
&error_exit(2, "XML::Parser Perl module is not installed");
|
||||
}
|
||||
eval { require XML::Parser; 1 }
|
||||
or &error_exit(2, "XML::Parser Perl module is not installed");
|
||||
|
||||
# Read in the XML
|
||||
my $rawxml;
|
||||
my $rawxml = "";
|
||||
if ($command_line) {
|
||||
# From STDIN
|
||||
while(<STDIN>) {
|
||||
@@ -52,7 +55,7 @@ if ($command_line) {
|
||||
}
|
||||
else {
|
||||
# From web client
|
||||
my $clen = $ENV{'CONTENT_LENGTH'};
|
||||
my $clen = $ENV{'CONTENT_LENGTH'} || 0;
|
||||
while(length($rawxml) < $clen) {
|
||||
my $buf;
|
||||
my $got = read(STDIN, $buf, $clen - length($rawxml));
|
||||
@@ -64,7 +67,7 @@ else {
|
||||
}
|
||||
|
||||
# Parse the XML
|
||||
my $parser = new XML::Parser('Style' => 'Tree');
|
||||
my $parser = XML::Parser->new('Style' => 'Tree');
|
||||
my $xml;
|
||||
eval { $xml = $parser->parse($rawxml); };
|
||||
if ($@) {
|
||||
@@ -72,11 +75,11 @@ if ($@) {
|
||||
}
|
||||
|
||||
# Look for the method calls, and invoke each one
|
||||
my %done_require_module;
|
||||
my $xmlrv = "<?xml version=\"1.0\" encoding=\"$default_charset\"?>\n";
|
||||
foreach my $mc (&find_xmls("methodCall", $xml)) {
|
||||
# Find the method name and module
|
||||
my ($mn) = &find_xmls("methodName", $mc);
|
||||
$h = $mn->[1]->[0];
|
||||
my ($mod, $func) = $mn->[1]->[2] =~ /::/ ?
|
||||
split(/::/, $mn->[1]->[2]) :
|
||||
$mn->[1]->[2] =~ /\./ ?
|
||||
@@ -100,7 +103,7 @@ foreach my $mc (&find_xmls("methodCall", $xml)) {
|
||||
&error_exit(5,
|
||||
"Webmin module $mod does not exist");
|
||||
}
|
||||
eval { &foreign_require($mod, $lib); };
|
||||
eval { &foreign_require($mod); };
|
||||
if ($@) {
|
||||
$xmlrv .= &make_error_xml(6,
|
||||
"Failed to load module $mod : $@");
|
||||
@@ -113,7 +116,7 @@ foreach my $mc (&find_xmls("methodCall", $xml)) {
|
||||
my @rv;
|
||||
if ($func eq "eval") {
|
||||
# Execute some Perl code
|
||||
@rv = eval "$args[0]";
|
||||
@rv = eval $args[0]; ## no critic (ProhibitStringyEval)
|
||||
if ($@) {
|
||||
$xmlrv .= &make_error_xml(8, "Eval failed : $@");
|
||||
}
|
||||
@@ -154,6 +157,8 @@ if (!$command_line) {
|
||||
}
|
||||
print $xmlrv;
|
||||
|
||||
} # end of unless (caller)
|
||||
|
||||
# parse_xml_value(&value)
|
||||
# Given a <value> object, returns a Perl scalar, hash ref or array ref for
|
||||
# the contents
|
||||
@@ -208,7 +213,7 @@ else {
|
||||
# Given a Perl object, returns XML lines representing it for return to a caller
|
||||
sub encode_xml_value
|
||||
{
|
||||
local ($perlv) = @_;
|
||||
my ($perlv) = @_;
|
||||
if (ref($perlv) eq "ARRAY") {
|
||||
# Convert to array XML format
|
||||
my $xmlrv = "<array>\n<data>\n";
|
||||
@@ -256,8 +261,8 @@ else {
|
||||
# Returns the XMLs object with some name, by recursively searching the XML
|
||||
sub find_xmls
|
||||
{
|
||||
local ($name, $conf, $depth) = @_;
|
||||
local @m = ref($name) ? @$name : ( $name );
|
||||
my ($name, $conf, $depth) = @_;
|
||||
my @m = ref($name) ? @$name : ( $name );
|
||||
if (&indexoflc($conf->[0], @m) >= 0) {
|
||||
# Found it!
|
||||
return ( $conf );
|
||||
@@ -269,11 +274,13 @@ else {
|
||||
# Gone too far .. stop
|
||||
return ( );
|
||||
}
|
||||
local $i;
|
||||
local $list = $conf->[1];
|
||||
local @rv;
|
||||
for($i=1; $i<@$list; $i+=2) {
|
||||
local @srv = &find_xmls($name,
|
||||
my $list = $conf->[1];
|
||||
# A char-data leaf has a plain string here, not a child list. There
|
||||
# is nothing to scan, so stop before dereferencing it as an array.
|
||||
ref($list) eq 'ARRAY' || return ( );
|
||||
my @rv;
|
||||
for(my $i=1; $i<@$list; $i+=2) {
|
||||
my @srv = &find_xmls($name,
|
||||
[ $list->[$i], $list->[$i+1] ],
|
||||
defined($depth) ? $depth-1 : undef);
|
||||
push(@rv, @srv);
|
||||
@@ -305,10 +312,12 @@ print $xmlerr;
|
||||
exit($command_line ? $code : 0);
|
||||
}
|
||||
|
||||
# make_error_xml(code, message)
|
||||
# Returns an XML methodResponse fault document for the given code and message
|
||||
sub make_error_xml
|
||||
{
|
||||
my ($code, $msg) = @_;
|
||||
$xmlerr .= "<methodResponse>\n";
|
||||
my $xmlerr = "<methodResponse>\n";
|
||||
$xmlerr .= "<fault>\n";
|
||||
$xmlerr .= "<value>\n";
|
||||
$xmlerr .= &encode_xml_value( { 'faultCode' => $code,
|
||||
|
||||
Reference in New Issue
Block a user