xmlrpc.cgi

   1 #!/usr/local/bin/perl
   2 # Handles xml-rpc requests from arbitrary clients. Each is a call to a
   3 # function in a Webmin module.
   4 # XXX special function for file transfer?
   5 # XXX command-line mode
   6
   7 if (!$ENV{'GATEWAY_INTERFACE'}) {
   8         # Command-line mode
   9         $no_acl_check++;
  10         $ENV{'WEBMIN_CONFIG'} ||= "/etc/webmin";
  11         $ENV{'WEBMIN_VAR'} ||= "/var/webmin";
  12         if ($0 =~ /^(.*\/)[^\/]+$/) {
  13                 chdir($1);
  14                 }
  15         chop($pwd = `pwd`);
  16         $0 = "$pwd/xmlrpc.pl";
  17         $command_line = 1;
  18         $< == 0 || die "xmlrpc.pl must be run as root";
  19         }
  20 BEGIN { push(@INC, ".."); };
  21 use WebminCore;
  22 use POSIX;
  23 use Socket;
  24 $force_lang = $default_lang;
  25 $trust_unknown_referers = 1;
  26 &init_config();
  27 $main::error_must_die = 1;
  28
  29 # Can this user make remote calls?
  30 if (!$command_line) {
  31         %access = &get_module_acl();
  32         if ($access{'rpc'} == 0 || $access{'rpc'} == 2 &&
  33             $base_remote_user ne 'admin' && $base_remote_user ne 'root' &&
  34             $base_remote_user ne 'sysadm') {
  35                 &error_exit(1, "Invalid user for RPC");
  36                 }
  37         }
  38
  39 # Load the XML parser module
  40 eval "use XML::Parser";
  41 if ($@) {
  42         &error_exit(2, "XML::Parser Perl module is not installed");
  43         }
  44
  45 # Read in the XML
  46 my $rawxml;
  47 if ($command_line) {
  48         # From STDIN
  49         while(<STDIN>) {
  50                 $rawxml .= $_;
  51                 }
  52         }
  53 else {
  54         # From web client
  55         my $clen = $ENV{'CONTENT_LENGTH'};
  56         while(length($rawxml) < $clen) {
  57                 my $buf;
  58                 my $got = read(STDIN, $buf, $clen - length($rawxml));
  59                 if ($got <= 0) {
  60                         &error_exit(3, "Failed to read $clen bytes");
  61                         }
  62                 $rawxml .= $buf;
  63                 }
  64         }
  65
  66 # Parse the XML
  67 my $parser = new XML::Parser('Style' => 'Tree');
  68 my $xml;
  69 eval { $xml = $parser->parse($rawxml); };
  70 if ($@) {
  71         &error_exit(4, "Invalid XML : $@");
  72         }
  73
  74 # Look for the method calls, and invoke each one
  75 my $xmlrv = "<?xml version=\"1.0\" encoding=\"$default_charset\"?>\n";
  76 foreach my $mc (&find_xmls("methodCall", $xml)) {
  77         # Find the method name and module
  78         my ($mn) = &find_xmls("methodName", $mc);
  79         $h = $mn->[1]->[0];
  80         my ($mod, $func) = $mn->[1]->[2] =~ /::/ ?
  81                                 split(/::/, $mn->[1]->[2]) :
  82                            $mn->[1]->[2] =~ /\./ ?
  83                                 split(/\./, $mn->[1]->[2]) :
  84                                 (undef, $mn->[1]->[2]);
  85
  86         # Find the parameters
  87         my ($params) = &find_xmls("params", $mc);
  88         my @params = &find_xmls("param", $params);
  89         my @args;
  90         foreach my $p (@params) {
  91                 my ($value) = &find_xmls("value", $p, 1);
  92                 my $perlv = &parse_xml_value($value);
  93                 push(@args, $perlv);
  94                 }
  95
  96         # Require the module, if needed
  97         if ($mod) {
  98                 if (!$done_require_module{$mod}) {
  99                         if (!&foreign_check($mod)) {
 100                                 &error_exit(5,
 101                                         "Webmin module $mod does not exist");
 102                                 }
 103                         eval { &foreign_require($mod, $lib); };
 104                         if ($@) {
 105                                 $xmlrv .= &make_error_xml(6,
 106                                         "Failed to load module $mod : $@");
 107                                 last;
 108                                 }
 109                         }
 110                 }
 111
 112         # Call the function
 113         my @rv;
 114         if ($func eq "eval") {
 115                 # Execute some Perl code
 116                 @rv = eval "$args[0]";
 117                 if ($@) {
 118                         $xmlrv .= &make_error_xml(8, "Eval failed : $@");
 119                         }
 120                 }
 121         else {
 122                 # A real function call
 123                 eval { @rv = &foreign_call($mod, $func, @args); };
 124                 if ($@) {
 125                         $xmlrv .= &make_error_xml(7,
 126                                 "Function call $func failed : $@");
 127                         last;
 128                         }
 129                 }
 130
 131         # Encode the results
 132         $xmlrv .= "<methodResponse>\n";
 133         $xmlrv .= "<params>\n";
 134         $xmlrv .= "<param><value>\n";
 135         if (@rv == 1) {
 136                 $xmlrv .= &encode_xml_value($rv[0]);
 137                 }
 138         else {
 139                 $xmlrv .= &encode_xml_value(\@rv);
 140                 }
 141         $xmlrv .= "</value></param>\n";
 142         $xmlrv .= "</params>\n";
 143         $xmlrv .= "</methodResponse>\n";
 144         }
 145
 146 # Flush all modified files, as some APIs require a call to this function
 147 &flush_file_lines();
 148
 149 # Return results to caller
 150 if (!$command_line) {
 151         print "Content-type: text/xml\n";
 152         print "Content-length: ",length($xmlrv),"\n";
 153         print "\n";
 154         }
 155 print $xmlrv;
 156
 157 # parse_xml_value(&value)
 158 # Given a <value> object, returns a Perl scalar, hash ref or array ref for
 159 # the contents
 160 sub parse_xml_value
 161 {
 162 my ($value) = @_;
 163 my ($scalar) = &find_xmls([ "int", "i4", "boolean", "string", "double" ],
 164                           $value, 1);
 165 my ($date) = &find_xmls([ "dateTime.iso8601" ], $value, 1);
 166 my ($base64) = &find_xmls("base64", $value, 1);
 167 my ($struct) = &find_xmls("struct", $value, 1);
 168 my ($array) = &find_xmls("array", $value, 1);
 169 if ($scalar) {
 170         return $scalar->[1]->[2];
 171         }
 172 elsif ($date) {
 173         # Need to decode date
 174         # XXX format?
 175         }
 176 elsif ($base64) {
 177         # Convert to binary
 178         return &decode_base64($base64->[1]->[2]);
 179         }
 180 elsif ($struct) {
 181         # Parse member names and values
 182         my %rv;
 183         foreach my $member (&find_xmls("member", $struct, 1)) {
 184                 my ($name) = &find_xmls("name", $member, 1);
 185                 my ($value) = &find_xmls("value", $member, 1);
 186                 my $perlv = &parse_xml_value($value);
 187                 $rv{$name->[1]->[2]} = $perlv;
 188                 }
 189         return \%rv;
 190         }
 191 elsif ($array) {
 192         # Parse data values
 193         my @rv;
 194         my ($data) = &find_xmls("data", $array, 1);
 195         foreach my $value (&find_xmls("value", $data, 1)) {
 196                 my $perlv = &parse_xml_value($value);
 197                 push(@rv, $perlv);
 198                 }
 199         return \@rv;
 200         }
 201 else {
 202         # Fallback - just a string directly in the value
 203         return $value->[1]->[2];
 204         }
 205 }
 206
 207 # encode_xml_value(string|int|&hash|&array)
 208 # Given a Perl object, returns XML lines representing it for return to a caller
 209 sub encode_xml_value
 210 {
 211 local ($perlv) = @_;
 212 if (ref($perlv) eq "ARRAY") {
 213         # Convert to array XML format
 214         my $xmlrv = "<array>\n<data>\n";
 215         foreach my $v (@$perlv) {
 216                 $xmlrv .= "<value>\n";
 217                 $xmlrv .= &encode_xml_value($v);
 218                 $xmlrv .= "</value>\n";
 219                 }
 220         $xmlrv .= "</data>\n</array>\n";
 221         return $xmlrv;
 222         }
 223 elsif (ref($perlv) eq "HASH") {
 224         # Convert to struct XML format
 225         my $xmlrv = "<struct>\n";
 226         foreach my $k (keys %$perlv) {
 227                 $xmlrv .= "<member>\n";
 228                 $xmlrv .= "<name>".&html_escape($k)."</name>\n";
 229                 $xmlrv .= "<value>\n";
 230                 $xmlrv .= &encode_xml_value($perlv->{$k});
 231                 $xmlrv .= "</value>\n";
 232                 $xmlrv .= "</member>\n";
 233                 }
 234         $xmlrv .= "</struct>\n";
 235         return $xmlrv;
 236         }
 237 elsif ($perlv =~ /^\-?\d+$/) {
 238         # Return an integer
 239         return "<int>$perlv</int>\n";
 240         }
 241 elsif ($perlv =~ /^\-?\d*\.\d+$/) {
 242         # Return a double
 243         return "<double>$perlv</double>\n";
 244         }
 245 elsif ($perlv =~ /^[\40-\377]*$/) {
 246         # Return a scalar
 247         return "<string>".&html_escape($perlv)."</string>\n";
 248         }
 249 else {
 250         # Contains non-printable characters, so return as base64
 251         return "<base64>".&encode_base64($perlv)."</base64>\n";
 252         }
 253 }
 254
 255 # find_xmls(name|&names, &config, [depth])
 256 # Returns the XMLs object with some name, by recursively searching the XML
 257 sub find_xmls
 258 {
 259 local ($name, $conf, $depth) = @_;
 260 local @m = ref($name) ? @$name : ( $name );
 261 if (&indexoflc($conf->[0], @m) >= 0) {
 262         # Found it!
 263         return ( $conf );
 264         }
 265 else {
 266         # Need to recursively scan all sub-elements, except for the first
 267         # which is just the tags of this element
 268         if (defined($depth) && !$depth) {
 269                 # Gone too far .. stop
 270                 return ( );
 271                 }
 272         local $i;
 273         local $list = $conf->[1];
 274         local @rv;
 275         for($i=1; $i<@$list; $i+=2) {
 276                 local @srv = &find_xmls($name,
 277                                        [ $list->[$i], $list->[$i+1] ],
 278                                        defined($depth) ? $depth-1 : undef);
 279                 push(@rv, @srv);
 280                 }
 281         return @rv;
 282         }
 283 return ( );
 284 }
 285
 286 # error_exit(code, message)
 287 # Output an XML error message
 288 sub error_exit
 289 {
 290 my ($code, $msg) = @_;
 291 $msg =~ s/\r|\n$//;
 292 $msg =~ s/\r|\n/ /g;
 293
 294 # Construct error XML
 295 my $xmlerr = "<?xml version=\"1.0\"?>\n";
 296 $xmlerr .= &make_error_xml($code, $msg);
 297
 298 # Send the error XML
 299 if (!$command_line) {
 300         print "Content-type: text/xml\n";
 301         print "Content-length: ",length($xmlerr),"\n";
 302         print "\n";
 303         }
 304 print $xmlerr;
 305 exit($command_line ? $code : 0);
 306 }
 307
 308 sub make_error_xml
 309 {
 310 my ($code, $msg) = @_;
 311 $xmlerr .= "<methodResponse>\n";
 312 $xmlerr .= "<fault>\n";
 313 $xmlerr .= "<value>\n";
 314 $xmlerr .= &encode_xml_value( { 'faultCode' => $code,
 315                                 'faultString' => $msg });
 316 $xmlerr .= "</value>\n";
 317 $xmlerr .= "</fault>\n";
 318 $xmlerr .= "</methodResponse>\n";
 319 return $xmlerr;
 320 }
 321
 322