Genixmlrpc.pm.in 7.46 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -w
#
3
# GENIPUBLIC-COPYRIGHT
Leigh B Stoller's avatar
Leigh B Stoller committed
4
# Copyright (c) 2008-2011 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
5
6
7
8
9
10
11
12
13
14
15
# All rights reserved.
#
# 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
16
@EXPORT = qw();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
17

18
# Must come after package declaration.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
19
use English;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
20
use GeniResponse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
21
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
22

23
24
25
my $debug   = 1;

# Let the caller set a timeout for a call.
26
my $timeout = 500;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

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

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
#
# 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) = @_;

Leigh B. Stoller's avatar
Leigh B. Stoller committed
61
    $keyfile = $certificate->certfile()
62
63
64
	if (!defined($keyfile));

    my $self = {"certificate"  => $certificate,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
65
		"certfile"     => $certificate->certfile(),
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
		"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";
82
83
    $user->SSLPassPhrase(1, \$password) == 0
	or return undef;
84

Leigh B. Stoller's avatar
Leigh B. Stoller committed
85
86
    my $self = {"certificate"  => undef,
		"certfile"     => $pkcs12,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
87
88
89
90
91
		"keyfile"      => $pkcs12,
		"password"     => $password,
		"user"	       => $user};
    bless($self, $class);
    return $self;
92
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
93
94
95
# accessors
sub field($$)           { return ($_[0]->{$_[1]}); }
sub certificate($)	{ return field($_[0], "certificate"); }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
96
sub certfile($)		{ return field($_[0], "certfile"); }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
97
98
99
sub keyfile($)		{ return field($_[0], "keyfile"); }
sub password($)		{ return field($_[0], "password"); }
sub user($)		{ return field($_[0], "user"); }
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114

#
# 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
115
116
117
118
119
120
sub GetContext($)
{
    my ($class) = @_;

    return $MyContext;
}
121
122
123
124
125
126
127
sub SetTimeout($$)
{
    my ($class, $to) = @_;

    $timeout = $to;
    return 0;
}
128

Leigh B. Stoller's avatar
Leigh B. Stoller committed
129
130
131
132
133
#
# Call to a non-Emulab xmlrpc server.  
# If there was an HTTP error, the hash also contains the keys
# httpcode and httpmsg.
#
134
sub CallMethod($$$@)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
135
{
136
    my ($httpURL, $context, $method, @args) = @_;
137
138
139
140
141
142
    require RPC::XML;
    require RPC::XML::Parser;
    require LWP::UserAgent;
    require HTTP::Request::Common;
    import HTTP::Request::Common;
    require HTTP::Headers;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
143

144
145
146
147
148
149
150
151
152
153
    # 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");
    }
154

155
    if (0) {
156
157
158
159
	#
	# This does not work. Not sure why, but need to figure it out
	# cause it does cert chains while Crypt::SSL (below) does not. 
	#
160
161
162
163
164
165
	$IO::Socket::SSL::DEBUG = 4;
	$Net::SSLeay::slowly = 1;
	
	$IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_key_file'} =
	    $context->keyfile();	    
	$IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_cert_file'} =
Leigh B. Stoller's avatar
Leigh B. Stoller committed
166
	    $context->certfile();	    
167
168
169
170
171
172
173
174
175
176
	$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())) {
	    $IO::Socket::SSL::GLOBAL_CONTEXT_ARGS->{'SSL_passwd_cb'} =
		sub { return $context->password(); };
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
177
178
    }
    else {
179
180
181
182
183
184
185
	#
	# 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.
	#
186
	if (!defined($context->password())) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
187
	    $ENV{'HTTPS_CERT_FILE'} = $context->certfile();
188
189
190
	    $ENV{'HTTPS_KEY_FILE'}  = $context->keyfile();
	}
	else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
191
	    $ENV{'HTTPS_PKCS12_FILE'}     = $context->certfile();
192
193
	    $ENV{'HTTPS_PKCS12_PASSWORD'} = $context->password();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
194
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
195
    my $request = new RPC::XML::request($method, @args);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
196
    if ($debug > 1) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
197
	print STDERR "xml request: $httpURL:" . $request->as_string();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
198
199
200
201
202
203
204
205
	print STDERR "\n";
    }

    #
    # Send an http post.
    #
    my $reqstr = $request->as_string();
    my $ua = LWP::UserAgent->new();
206
207
    $ua->timeout($timeout)
	if ($timeout > 0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
208
209
210
211
212
    my $hreq = HTTP::Request->new(POST => $httpURL);
    $hreq->content_type('text/xml');
    $hreq->content($reqstr);
    my $hresp = $ua->request($hreq);

Leigh B. Stoller's avatar
Leigh B. Stoller committed
213
214
215
216
217
218
219
    # 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())) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
220
221
222
223
224
	print STDERR "xml response: " . $hresp->as_string();
	print STDERR "\n";
    }
    
    if (!$hresp->is_success()) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
225
226
	return GeniResponse->new(GENIRESPONSE_RPCERROR,
				 $hresp->code(), $hresp->message());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
227
228
229
230
231
232
233
    }

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
234
    if ($debug > 1) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
235
236
237
238
239
240
241
	print STDERR "xmlgoo: " . $xmlgoo;
	print STDERR "\n";
    }

    #
    # Convert the xmlgoo to Perl and return it.
    #
242
    $xmlgoo =~ s/\<nil\/\>//g;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
243
244
245
    my $parser   = RPC::XML::Parser->new();
    my $goo      = $parser->parse($xmlgoo);
    my ($value,$output,$code);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
246
247

    #print Dumper($goo);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
248
249
250
251
252
253
254
255
256
257
    
    # 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'}))) {
258
	$code   = $goo->value()->{"faultCode"}->value;
259
	$value  = $goo->value()->{"faultCode"}->value;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
260
261
	$output = $goo->value()->{"faultString"}->value;
    }
262
263
264
265
266
267
268
    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
269
    else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
270
271
272
	$code   = $goo->value()->{'code'}->value;
	$value  = $goo->value()->{'value'}->value;
	$output = $goo->value()->{'output'}->value;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
273
    }
274
    if ($debug > 1 && $code) {
275
276
	print STDERR "CallMethod: $method failed: $code";
	print STDERR ", $output\n" if (defined($output) && $output ne "");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
277
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
278
    return GeniResponse->new($code, $value, $output);
279

Leigh B. Stoller's avatar
Leigh B. Stoller committed
280
281
282
283
}

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