diff --git a/t/xmlrpc.t b/t/xmlrpc.t new file mode 100644 index 000000000..eace24a3e --- /dev/null +++ b/t/xmlrpc.t @@ -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 body +# parse_xml_value - parsed XML node -> Perl scalar/ref +# find_xmls - recursive element search over an XML::Parser tree +# make_error_xml - faultCode/faultString -> 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 ... 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("$body"); +} + +# 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), "5\n", 'positive int'); + is(encode_xml_value(-3), "-3\n", 'negative int'); + is(encode_xml_value(0), "0\n", 'zero is an int'); + + # Doubles. + like(encode_xml_value('3.14'), qr{^3\.14\s*$}, 'decimal -> double'); + like(encode_xml_value('-0.5'), qr{^-0\.5\s*$}, 'signed decimal -> double'); + + # Plain strings. + like(encode_xml_value('hello'), qr{^hello\s*$}, 'word -> string'); + like(encode_xml_value(''), qr{^\s*$}, 'empty string -> empty '); + + # A value with control characters cannot live in a (the + # printable-range regex fails), so it must fall through to base64. + like(encode_xml_value("a\tb\n"), qr{^.*\s*$}s, + 'control chars force base64 encoding'); +}; + +subtest 'encode_xml_value escapes markup' => sub { + my $out = encode_xml_value('&"x"'); + unlike($out, qr//, '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({ '' => 'v' }); + unlike($s, qr/ 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{.*.*.*}s, 'nested array rendered inside struct'); + + # A flat array of mixed scalar types: one wrapper each. + my $arr = encode_xml_value([5, 'hi', 'x']); + like($arr, qr{^\s*}s, 'array opens with '); + my $vopen = () = $arr =~ //g; + my $vclose = () = $arr =~ /<\/value>/g; + is($vopen, $vclose, ' wrappers balanced in array'); + is($vopen, 3, 'one 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 { + # xy + my $tree = [ 'a', [ {}, + 'b', [ {}, 0, 'x' ], + 'c', [ {}, 'b', [ {}, 0, 'y' ] ], + ] ]; + + my @b = find_xmls('b', $tree); + is(scalar @b, 2, 'finds both elements at any depth'); + is($b[0]->[0], 'b', 'returned node carries its tag name'); + is($b[0]->[1]->[2], 'x', 'first text reachable at content index 2'); + + # Depth limiting: depth 1 only looks at direct children, so the + # nested inside is not reached. + my @shallow = find_xmls('b', $tree, 1); + is(scalar @shallow, 1, 'depth=1 finds only the direct-child '); + + # Name-list form matches any of several tags (case-insensitively, + # via indexoflc). Search stops descending at a match, so the + # nested inside the matched is not also returned. + my @bc = find_xmls([ 'c', 'b' ], $tree); + is(scalar @bc, 2, 'name-list matches the outer and the , 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('42')), 42, 'int parsed'); + is(parse_xml_value(value_tree('7')), 7, 'i4 alias parsed'); + is(parse_xml_value(value_tree('1')),1, 'boolean parsed'); + is(parse_xml_value(value_tree('2.5')),'2.5', 'double parsed'); + is(parse_xml_value(value_tree('hi')), '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("$b64")), "ab\x00cd", + 'base64 decoded to raw bytes'); + + # struct -> hashref. + my $h = parse_xml_value(value_tree( + 'k1')); + is(ref($h), 'HASH', 'struct -> hashref'); + is($h->{k}, 1, 'struct member value parsed'); + + # array -> arrayref. + my $a = parse_xml_value(value_tree( + '1x')); + 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{.*.*.*}s, + 'fault wrapped in methodResponse'); + like($err, qr{faultCode}, 'carries faultCode member'); + like($err, qr{faultString}, 'carries faultString member'); + like($err, qr{7}, '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 =~ //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 =~ //g; + my $close = () = $multiline =~ /<\/methodResponse>/g; + is($open, $close, 'methodResponse balanced with multiline message'); +}; + +done_testing(); diff --git a/xmlrpc.cgi b/xmlrpc.cgi index aaebefb35..3a99405fe 100755 --- a/xmlrpc.cgi +++ b/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() { @@ -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 = "\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 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 = "\n\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 .= "\n"; +my $xmlerr = "\n"; $xmlerr .= "\n"; $xmlerr .= "\n"; $xmlerr .= &encode_xml_value( { 'faultCode' => $code,