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