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