Genixmlrpc.pm.in

#!/usr/bin/perl -w
#
# Copyright (c) 2008-2015 University of Utah and the Flux Group.
# 
# {{{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.
# 
# }}}
#
# 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";
@EXPORT = qw();

# Must come after package declaration.
use English;
use GeniResponse;
use Data::Dumper;

my $debug   = 1;

# Let the caller set a timeout for a call.
my $timeout = 500;

##
# 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
#

#
# 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) = @_;

    $keyfile = $certificate->certfile()
	if (!defined($keyfile));

    my $self = {"certificate"  => $certificate,
		"certfile"     => $certificate->certfile(),
		"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";
    $user->SSLPassPhrase(1, \$password) == 0
	or return undef;

    my $self = {"certificate"  => undef,
		"certfile"     => $pkcs12,
		"keyfile"      => $pkcs12,
		"password"     => $password,
		"user"	       => $user};
    bless($self, $class);
    return $self;
}
# accessors
sub field($$)           { return ($_[0]->{$_[1]}); }
sub certificate($)	{ return field($_[0], "certificate"); }
sub certfile($)		{ return field($_[0], "certfile"); }
sub keyfile($)		{ return field($_[0], "keyfile"); }
sub password($)		{ return field($_[0], "password"); }
sub user($)		{ return field($_[0], "user"); }

#
# 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;
}
sub GetContext($)
{
    my ($class) = @_;

    return $MyContext;
}
sub SetTimeout($$)
{
    my ($class, $to) = @_;

    $timeout = $to;
    return 0;
}

#
# Call to a non-Emulab xmlrpc server.  
# If there was an HTTP error, the hash also contains the keys
# httpcode and httpmsg.
#
sub CallMethod($$$@)
{
    my ($httpURL, $context, $method, @args) = @_;
    require RPC::XML;
    require RPC::XML::Parser;
    require HTTP::Request::Common;
    import HTTP::Request::Common;
    require HTTP::Headers;

    # 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";	
	return GeniResponse->new(GENIRESPONSE_RPCERROR, -1,
				 "Must provide an rpc context");
    }

    my $FBSD_MAJOR = 4;
    my $FBSD_MINOR = 10;
    if (`/usr/bin/uname -r` =~ /^(\d+)\.(\d+)/) {
	$FBSD_MAJOR = $1;
	$FBSD_MINOR = $2;
    }
    else {
	print STDERR
	    "Could not determine what version of FreeBSD you are running!\n";	
	return GeniResponse->new(GENIRESPONSE_RPCERROR, -1,
	    "Could not determine what version of FreeBSD you are running!");
    }
    
    if ($FBSD_MAJOR >= 8) {
	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;
	
	#
	# This does not work. Not sure why, but need to figure it out
	# cause it does cert chains while Crypt::SSL (below) does not. 
	#
	#$IO::Socket::SSL::DEBUG = 4;
	$Net::SSLeay::slowly = 1;

	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;
	}
	#
	# If we have a passphrase in the context, then provide a callback
	# to hand it back. Otherwise the user gets prompted for it.
	#
	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(); };
	    }
	}
    }
    else {
	require Net::SSL;
	require Net::HTTPS;
	$Net::HTTPS::SSL_SOCKET_CLASS = "Net::SSL";
	require LWP::UserAgent;
	
	#
	# 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.
	#
	if (!defined($context->password())) {
	    $ENV{'HTTPS_CERT_FILE'} = $context->certfile();
	    $ENV{'HTTPS_KEY_FILE'}  = $context->keyfile();
	}
	else {
	    $ENV{'HTTPS_PKCS12_FILE'}     = $context->certfile();
	    $ENV{'HTTPS_PKCS12_PASSWORD'} = $context->password();
	}
    }
    my $request = new RPC::XML::request($method, @args);
    if ($debug > 1) {
	print STDERR "xml request: $httpURL:" . $request->as_string();
	print STDERR "\n";
    }
    
    #
    # Send an http post.
    #
    my $reqstr = $request->as_string();
    my $ua = LWP::UserAgent->new();
    $ua->timeout($timeout)
	if ($timeout > 0);
    my $hreq = HTTP::Request->new(POST => $httpURL);
    $hreq->content_type('text/xml');
    $hreq->content($reqstr);
    $hreq->protocol('HTTP/1.0')	if ($FBSD_MAJOR >= 8);
    my $hresp = $ua->request($hreq);

    # 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'});
    
    if ($debug > 1 || ($debug && !$hresp->is_success())) {
	print STDERR "xml response: " . $hresp->as_string();
	print STDERR "\n";
    }
    
    if (!$hresp->is_success()) {
	return GeniResponse->new(GENIRESPONSE_RPCERROR,
				 $hresp->code(), $hresp->message());
    }

    #
    # Read back the xmlgoo from the child.
    #
    my $xmlgoo = $hresp->content();

    if ($debug > 1) {
	print STDERR "xmlgoo: " . $xmlgoo;
	print STDERR "\n";
    }

    #
    # Convert the xmlgoo to Perl and return it.
    #
    $xmlgoo =~ s/\<nil\/\>//g;
    my $parser   = RPC::XML::Parser->new();
    my $goo      = $parser->parse($xmlgoo);
    my ($value,$output,$code,$logurl);

    # Python servers seem to return faults in structs, not as <fault> elements.
    # Sigh.
    if (!ref($goo)) {
        print STDERR "Error in XMLRPC parse: $goo\n";
        return undef;
    }
    elsif ($goo->value()->is_fault() 
	|| (ref($goo->value()) && UNIVERSAL::isa($goo->value(),"HASH") 
	    && exists($goo->value()->{'faultCode'}))) {
	$code   = $goo->value()->{"faultCode"}->value;
	$value  = $goo->value()->{"faultCode"}->value;
	$output = $goo->value()->{"faultString"}->value;
	# EXO returns a bad fault structure.
	if (!$code) {
	    $code = $value = GENIRESPONSE_ERROR();
	}
    }
    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;
    }
    else {
	$code   = $goo->value()->{'code'}->value;
	#
	# New SFA based AMs use a hash for the code. Why?
	#
	if (UNIVERSAL::isa($code,"HASH")) {
	    $code = $code->{'geni_code'};
	}
	#
	# Orca returns no value if there is a fault.
	#
	if (!defined($goo->value()->{'value'})) {
	    $value = undef;
	}
	else {
	    $value  = $goo->value()->{'value'}->value;
	    $logurl = $goo->value()->{'protogeni_error_url'}->value
		if (exists($goo->value()->{'protogeni_error_url'}));
	}
	$output = $goo->value()->{'output'}->value
	    if (exists($goo->value()->{'output'}));
    }
    if ($debug > 1 && $code) {
	print STDERR "CallMethod: $method failed: $code";
	print STDERR ", $output\n" if (defined($output) && $output ne "");
    }
    return GeniResponse->new($code, $value, $output, $logurl);

}

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