Genixmlrpc.pm.in 14.9 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1 2
#!/usr/bin/perl -w
#
3
# Copyright (c) 2008-2018 University of Utah and the Flux Group.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
# 
# {{{GENIPUBLIC-LICENSE
# 
# GENI Public License
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and/or hardware specification (the "Work") to
# deal in the Work without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Work, and to permit persons to whom the Work
# is furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Work.
# 
# THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE WORK OR THE USE OR OTHER DEALINGS
# IN THE WORK.
# 
# }}}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29 30 31 32 33 34 35 36 37 38
#
# Perl code to access an XMLRPC server using http. Derived from the
# Emulab library (pretty sure Dave wrote the http code in that file,
# and I'm just stealing it).
#
package Genixmlrpc;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA    = "Exporter";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
39
@EXPORT = qw();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
40

41
# Must come after package declaration.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42
use English;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
43
use GeniResponse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
44
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
45

46 47 48
my $debug   = 1;

# Let the caller set a timeout for a call.
49
my $timeout = 500;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

##
# The package version number
#
my $PACKAGE_VERSION = 0.1;

#
# This is the "structure" returned by the RPC server. It gets converted into
# a perl hash by the unmarshaller, and we return that directly to the caller
# (as a reference).
#
# class EmulabResponse:
#    def __init__(self, code, value=0, output=""):
#        self.code     = code            # A RESPONSE code
#        self.value    = value           # A return value; any valid XML type.
#        self.output   = output          # Pithy output to print
#        return
#

69 70 71 72 73 74 75 76 77 78 79 80 81 82
#
# This is the context for making rpc calls. Gives the certificate and an
# optional password. The caller hangs onto this and passes it back in below.
#
# class XmlRpcContext:
#    def __init__(self, certificate, keyfile, password=None):
#        self.certificate = certificate
#        self.keyfile     = keyfile
#        self.password    = password
#        return
#
sub Context($$;$$)
{
    my ($class, $certificate, $keyfile, $password) = @_;
83
    my $certfile;
84

Leigh B. Stoller's avatar
Leigh B. Stoller committed
85
    $keyfile = $certificate->certfile()
86
	if (!defined($keyfile));
87 88 89 90 91 92 93 94
    
    if (ref($certificate)) {
	$certfile = $certificate->certfile();
    }
    else {
	$certfile = $certificate;
	$certificate = undef;
    }
95
    my $self = {"certificate"  => $certificate,
96
		"certfile"     => $certfile,
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
		"keyfile"      => $keyfile,
		"password"     => $password};
    bless($self, $class);
    return $self;
}

#
# This is a context for a user. Used only on Emulab bossnode. Use the
# Context() routine above on clients.
#
sub UserContext($$)
{
    my ($class, $user) = @_;
    my $password;

    my $pkcs12 = $user->HomeDir() . "/.ssl/encrypted.p12";
113 114
    $user->SSLPassPhrase(1, \$password) == 0
	or return undef;
115

Leigh B. Stoller's avatar
Leigh B. Stoller committed
116 117
    my $self = {"certificate"  => undef,
		"certfile"     => $pkcs12,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
118 119 120 121 122
		"keyfile"      => $pkcs12,
		"password"     => $password,
		"user"	       => $user};
    bless($self, $class);
    return $self;
123
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
124 125 126
# accessors
sub field($$)           { return ($_[0]->{$_[1]}); }
sub certificate($)	{ return field($_[0], "certificate"); }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
127
sub certfile($)		{ return field($_[0], "certfile"); }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
128 129 130
sub keyfile($)		{ return field($_[0], "keyfile"); }
sub password($)		{ return field($_[0], "password"); }
sub user($)		{ return field($_[0], "user"); }
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145

#
# Context for making calls.
#
my $MyContext;

# Set the context for subsequent calls made to the clearing house.
#
sub SetContext($$)
{
    my ($class, $context) = @_;

    $MyContext = $context;
    return 0;
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
146 147 148 149 150 151
sub GetContext($)
{
    my ($class) = @_;

    return $MyContext;
}
152 153 154
sub SetTimeout($$)
{
    my ($class, $to) = @_;
155
    my $old = $timeout;
156 157

    $timeout = $to;
158
    return $old;
159
}
160

161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
BEGIN {
    require Frontier::Responder;
    require Frontier::RPC2;

    # Original version of traversal function.
    my $rpc2_item = \&Frontier::RPC2::_item;

    {
	no warnings 'redefine';

	# Redefine to handle the URN object. It would be nice if this was
	# a builtin feature (being able to handle arbitrary classes).
	*Frontier::RPC2::_item = sub {
	    my ($self,$item) = @_;
	    if (ref($item) eq "GeniHRN") {
		# Just a string.
		return Frontier::RPC2::_scalar($self,$item->urn());
	    }
	    return &$rpc2_item($self, $item);
	};
    }
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
184 185 186 187 188
#
# Call to a non-Emulab xmlrpc server.  
# If there was an HTTP error, the hash also contains the keys
# httpcode and httpmsg.
#
189
sub CallMethod($$$@)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
190
{
191
    my ($httpURL, $context, $method, @args) = @_;
192 193 194 195 196 197 198 199 200 201 202 203 204 205

    return CallMethodInternal($httpURL, $context, undef, $method, @args);
}
sub CallMethodStream($$$$@)
{
    my ($httpURL, $context, $fp, $method, @args) = @_;


    return CallMethodInternal($httpURL, $context, $fp, $method, @args);
}
sub CallMethodInternal($$$$@)
{
    my ($httpURL, $context, $fp, $method, @args) = @_;
    my $xmlgoo;
206 207 208 209 210
    require RPC::XML;
    require RPC::XML::Parser;
    require HTTP::Request::Common;
    import HTTP::Request::Common;
    require HTTP::Headers;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
211

212 213 214 215 216 217 218
    # Default context if not set.
    $context = $MyContext
	if (!defined($context));

    # But must have a context;
    if (!defined($context)) {
	print STDERR "Must provide an rpc context\n";	
219
	return GeniResponse->new(GENIRESPONSE_RPCERROR, XMLRPC_SYSTEM_ERROR,
220 221
				 "Must provide an rpc context");
    }
222 223 224 225 226
    # Testing mode.
    if (0) {
	return GeniResponse->new(GENIRESPONSE_RPCERROR, XMLRPC_SYSTEM_ERROR,
				 "Testing mode!");
    }
227

228 229 230 231 232 233 234 235 236 237 238 239 240 241
    # Callback to write the data, when streaming to a file.
    my $callback = sub {
	my ($data) = @_;
	if ($data =~ /^\<\?xml/) {
	    $xmlgoo = $data;
	    return;
	}
	my $retval = syswrite($fp, $data);
	if (!defined($retval)) {
	    die("Error writing data to output stream");
	}
	print ".";
    };

242 243 244 245 246 247 248 249
    my $FBSD_MAJOR = 4;
    my $FBSD_MINOR = 10;
    if (`/usr/bin/uname -r` =~ /^(\d+)\.(\d+)/) {
	$FBSD_MAJOR = $1;
	$FBSD_MINOR = $2;
    }
    else {
	print STDERR
250
	    "Could not determine what version of FreeBSD you are running!\n";	
251
	return GeniResponse->new(GENIRESPONSE_RPCERROR, XMLRPC_SYSTEM_ERROR,
252
	    "Could not determine what version of FreeBSD you are running!");
253 254
    }
    
255
    if ($FBSD_MAJOR >= 8) {
256 257 258 259 260 261 262 263
	require LWP::UserAgent;
	require IO::Socket::SSL;
	require Net::HTTPS;
	$Net::HTTPS::SSL_SOCKET_CLASS = "IO::Socket::SSL";

	# Turn off silly check many levels down.
	$ENV{'PERL_LWP_SSL_VERIFY_HOSTNAME'} = 0;
	
264 265 266 267
	#
	# This does not work. Not sure why, but need to figure it out
	# cause it does cert chains while Crypt::SSL (below) does not. 
	#
268
	#$IO::Socket::SSL::DEBUG = 4;
269 270
	$Net::SSLeay::slowly = 1;

271 272 273 274 275 276 277 278 279 280 281 282
	if ($FBSD_MAJOR >= 10) {
	    IO::Socket::SSL::set_defaults('SSL_key_file' => $context->keyfile(),
				'SSL_cert_file' => $context->certfile(),
				'SSL_use_cert' => 1);
	}
	else {
	    $IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_key_file'} =
		$context->keyfile();	    
	    $IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_cert_file'} =
		$context->certfile();	    
	    $IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_use_cert'} = 1;
	}
283 284 285 286
	#
	# If we have a passphrase in the context, then provide a callback
	# to hand it back. Otherwise the user gets prompted for it.
	#
287 288 289 290 291 292 293 294 295
	if (defined($context->password())) {	
	    if ($FBSD_MAJOR >= 10) {
		IO::Socket::SSL::set_defaults('SSL_passwd_cb' =>
					  sub { return $context->password(); });
	    }
	    else {
		$IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_passwd_cb'} =
		    sub { return $context->password(); };
	    }
296
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
297 298
    }
    else {
299 300 301 302 303
	require Net::SSL;
	require Net::HTTPS;
	$Net::HTTPS::SSL_SOCKET_CLASS = "Net::SSL";
	require LWP::UserAgent;
	
304 305 306 307 308 309 310
	#
	# This is for the Crypt::SSL library, many levels down. It
	# appears to be the only way to specify this. Even worse, when
	# we want to use an encrypted key belonging to a user, have to
	# use the pkcs12 format of the file, since that is the only
	# format for which we can provide the passphrase.
	#
311
	if (!defined($context->password())) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
312
	    $ENV{'HTTPS_CERT_FILE'} = $context->certfile();
313 314 315
	    $ENV{'HTTPS_KEY_FILE'}  = $context->keyfile();
	}
	else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
316
	    $ENV{'HTTPS_PKCS12_FILE'}     = $context->certfile();
317 318
	    $ENV{'HTTPS_PKCS12_PASSWORD'} = $context->password();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
319
    }
320 321
    my $encoder = Frontier::RPC2->new();
    my $reqstr  = $encoder->encode_call($method, @args);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
322
    if ($debug > 1) {
323
	print STDERR "xml request: $httpURL:" . $reqstr;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
324 325
	print STDERR "\n";
    }
326
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
327 328 329 330
    #
    # Send an http post.
    #
    my $ua = LWP::UserAgent->new();
331 332
    $ua->timeout($timeout)
	if ($timeout > 0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
333 334 335
    my $hreq = HTTP::Request->new(POST => $httpURL);
    $hreq->content_type('text/xml');
    $hreq->content($reqstr);
336
    $hreq->protocol('HTTP/1.0')	if ($FBSD_MAJOR >= 8);
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351

    #
    # Wrap this in an eval, so that if we get signaled, we can return
    # a proper response. 
    #
    my $hresp;
    eval {
	$hresp = (defined($fp) ?
		  $ua->request($hreq, $callback, 0x20000) :
		  $ua->request($hreq));
    };
    if ($@) {
	# Bad news, we want to whine.
	return GeniResponse->new(GENIRESPONSE_RPCERROR, undef, $@);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
352

Leigh B. Stoller's avatar
Leigh B. Stoller committed
353 354 355 356 357 358
    # Do this or the next call gets messed up.
    delete($ENV{'HTTPS_CERT_FILE'});
    delete($ENV{'HTTPS_KEY_FILE'});
    delete($ENV{'HTTPS_PKCS12_FILE'});
    delete($ENV{'HTTPS_PKCS12_PASSWORD'});
    
359
    if ($debug > 1) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
360 361
	print STDERR "xml response: " . $hresp->as_string();
	print STDERR "\n";
362
	print STDERR "------------------\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
363 364 365
    }
    
    if (!$hresp->is_success()) {
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
	my $code = $hresp->code();
	my $message = $hresp->message();
	
	if ($debug > 1) {
	    print STDERR "RPC Failure $code, $message\n";
	    print STDERR "------------------\n";
	}
	if ($code == HTTP_INTERNAL_SERVER_ERROR()) {
	    #
	    # We get here for what seems to be for one of three reasons:
	    #
	    # 1. Unable to reach the server. We do not know why, we just
	    #    cannot connect.
	    # 2. The connection times out. We do not know where it timed
	    #    out but typically it is because the server is taking too
	    #    long to answer. Note that the connection has probably been
	    #    successful and the server is working away. But we do not
	    #    know that for sure.
	    # 3. A total server error, either in apache or in the backend
	    #    scripts that are invoked.
	    #
	    # Sadly, we have to look at the string to know, which makes all
	    # this pretty damn fragile. 
	    #
	    # The first two errors are not something we can do much to
	    # fix, but in general the user does not care, he just needs to
	    # know the request cannot be completed cause of a network
	    # error.  So turn that into an error that the caller knows to
	    # pass through without generating (tons of) email.
	    #
	    if ($message =~ /read timeout/i) {
		return GeniResponse->new(GENIRESPONSE_NETWORK_ERROR,
					 GENIRESPONSE_NETWORK_ERROR_TIMEDOUT,
					 "Timed out talking to server");
	    }
	    if ($message =~ /Can\'t connect to/i ||
		# In case this changes to proper english
		$message =~ /Cannot connect to/i) {
		return GeniResponse->new(GENIRESPONSE_NETWORK_ERROR,
					 GENIRESPONSE_NETWORK_ERROR_NOCONNECT, 
					 "Cannot connect to server");
	    }
	    #
	    # The third one is bad, we want to make sure we whine about
	    # it, but do not send a bunch of gibberish to the user. 
	    #
	    if ($message =~ /Internal Server Error/i) {
		return GeniResponse->new(GENIRESPONSE_SERVERERROR,
					 $code, $message);
	    }
	}
417 418 419 420 421 422 423 424
	elsif ($code == HTTP_GATEWAY_TIME_OUT()) {
	    #
	    # This is the same as the read timeout above.
	    #
	    return GeniResponse->new(GENIRESPONSE_NETWORK_ERROR,
				     GENIRESPONSE_NETWORK_ERROR_TIMEDOUT,
				     "Timed out talking to server");
	}
425 426 427 428
	#
	# Otherwise bad news, we want to whine.
	#
	return GeniResponse->new(GENIRESPONSE_RPCERROR, $code, $message);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
429
    }
430 431 432 433
    # Streamed the data okay, we are done.
    if (defined($fp) && !defined($xmlgoo)) {
	return GeniResponse->new(GENIRESPONSE_SUCCESS);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
434 435 436 437

    #
    # Read back the xmlgoo from the child.
    #
438 439 440
    if (!defined($xmlgoo)) {
	$xmlgoo = $hresp->content();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
441
    if ($debug > 1) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
442 443 444 445 446 447 448
	print STDERR "xmlgoo: " . $xmlgoo;
	print STDERR "\n";
    }

    #
    # Convert the xmlgoo to Perl and return it.
    #
449
    $xmlgoo =~ s/\<nil\/\>//g;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
450 451
    my $parser   = RPC::XML::Parser->new();
    my $goo      = $parser->parse($xmlgoo);
452
    my ($value,$output,$code,$logurl);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
453

Leigh B. Stoller's avatar
Leigh B. Stoller committed
454 455 456
    # Python servers seem to return faults in structs, not as <fault> elements.
    # Sigh.
    if (!ref($goo)) {
Leigh B Stoller's avatar
Leigh B Stoller committed
457
        print STDERR "Error in XMLRPC parse: $xmlgoo\n";
458
	$code   = GENIRESPONSE_RPCERROR();
459
	$value  = XMLRPC_SYSTEM_ERROR;
460
	$output = "Could not parse XMLRPC return value: $xmlgoo";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
461 462 463 464
    }
    elsif ($goo->value()->is_fault() 
	|| (ref($goo->value()) && UNIVERSAL::isa($goo->value(),"HASH") 
	    && exists($goo->value()->{'faultCode'}))) {
465
	$code   = GENIRESPONSE_RPCERROR();
466
	$value  = $goo->value()->{"faultCode"}->value;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
467
	$output = $goo->value()->{"faultString"}->value;
468 469
	# EXO returns a bad fault structure.
	if (!$code) {
470 471 472 473 474 475 476 477 478
	    $value = GENIRESPONSE_ERROR();
	}
	#
	# Negative values are XMLRPC errors, these are bad and we want
	# to whine. Positive are different, look to see if they are one
	# of the ones we expect our servers to generate and convert.
	#
	if ($value == HTTP_SERVICE_UNAVAILABLE()) {
	    $code = GENIRESPONSE_SERVER_UNAVAILABLE();
479
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
480
    }
481 482 483 484 485 486 487
    elsif (! (ref($goo->value()) && UNIVERSAL::isa($goo->value(),"HASH") 
	      && exists($goo->value()->{'code'}))) {
	# Sadly, the AM interface returns a different structure.
	$code   = GENIRESPONSE_SUCCESS();
	$value  = $goo->value()->value;
	$output = undef;
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
488
    else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
489
	$code   = $goo->value()->{'code'}->value;
490 491 492 493 494 495
	#
	# New SFA based AMs use a hash for the code. Why?
	#
	if (UNIVERSAL::isa($code,"HASH")) {
	    $code = $code->{'geni_code'};
	}
496 497 498 499 500 501 502 503 504
	#
	# Orca returns no value if there is a fault.
	#
	if (!defined($goo->value()->{'value'})) {
	    $value = undef;
	}
	else {
	    $value  = $goo->value()->{'value'}->value;
	}
505 506
	$output = $goo->value()->{'output'}->value
	    if (exists($goo->value()->{'output'}));
507 508 509 510 511 512 513 514
	$logurl = $goo->value()->{'protogeni_error_url'}->value
	    if (exists($goo->value()->{'protogeni_error_url'}));
    }
    #
    # For consistency, make sure there is a subcode for RPCERROR.
    #
    if ($code == GENIRESPONSE_RPCERROR && !defined($value)) {
	$value = XMLRPC_SYSTEM_ERROR;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
515
    }
516
    if ($debug > 1 && $code) {
517 518
	print STDERR "CallMethod: $method failed: $code";
	print STDERR ", $output\n" if (defined($output) && $output ne "");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
519
    }
520 521
    if ($debug > 1 && $code == GENIRESPONSE_RPCERROR) {
	print STDERR "RPC Failure $value, $output\n";
522
    }
523
    return GeniResponse->new($code, $value, $output, $logurl);
524

Leigh B. Stoller's avatar
Leigh B. Stoller committed
525 526 527 528
}

# _Always_ make sure that this 1 is at the end of the file...
1;