Genixmlrpc.pm.in 10 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -w
#
3
# Copyright (c) 2008-2015 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
83
#
# 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
84
    $keyfile = $certificate->certfile()
85
86
87
	if (!defined($keyfile));

    my $self = {"certificate"  => $certificate,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
88
		"certfile"     => $certificate->certfile(),
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
		"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";
105
106
    $user->SSLPassPhrase(1, \$password) == 0
	or return undef;
107

Leigh B. Stoller's avatar
Leigh B. Stoller committed
108
109
    my $self = {"certificate"  => undef,
		"certfile"     => $pkcs12,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
110
111
112
113
114
		"keyfile"      => $pkcs12,
		"password"     => $password,
		"user"	       => $user};
    bless($self, $class);
    return $self;
115
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
116
117
118
# accessors
sub field($$)           { return ($_[0]->{$_[1]}); }
sub certificate($)	{ return field($_[0], "certificate"); }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
119
sub certfile($)		{ return field($_[0], "certfile"); }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
120
121
122
sub keyfile($)		{ return field($_[0], "keyfile"); }
sub password($)		{ return field($_[0], "password"); }
sub user($)		{ return field($_[0], "user"); }
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

#
# 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
138
139
140
141
142
143
sub GetContext($)
{
    my ($class) = @_;

    return $MyContext;
}
144
145
146
147
148
149
150
sub SetTimeout($$)
{
    my ($class, $to) = @_;

    $timeout = $to;
    return 0;
}
151

Leigh B. Stoller's avatar
Leigh B. Stoller committed
152
153
154
155
156
#
# Call to a non-Emulab xmlrpc server.  
# If there was an HTTP error, the hash also contains the keys
# httpcode and httpmsg.
#
157
sub CallMethod($$$@)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
158
{
159
    my ($httpURL, $context, $method, @args) = @_;
160
161
162
163
164
    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
165

166
167
168
169
170
171
172
173
174
175
    # 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");
    }
176

177
178
179
180
181
182
183
184
    my $FBSD_MAJOR = 4;
    my $FBSD_MINOR = 10;
    if (`/usr/bin/uname -r` =~ /^(\d+)\.(\d+)/) {
	$FBSD_MAJOR = $1;
	$FBSD_MINOR = $2;
    }
    else {
	print STDERR
185
186
187
	    "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!");
188
189
    }
    
190
    if ($FBSD_MAJOR >= 8) {
191
192
193
194
195
196
197
198
	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;
	
199
200
201
202
	#
	# This does not work. Not sure why, but need to figure it out
	# cause it does cert chains while Crypt::SSL (below) does not. 
	#
203
	#$IO::Socket::SSL::DEBUG = 4;
204
205
	$Net::SSLeay::slowly = 1;

206
207
208
209
210
211
212
213
214
215
216
217
	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;
	}
218
219
220
221
	#
	# If we have a passphrase in the context, then provide a callback
	# to hand it back. Otherwise the user gets prompted for it.
	#
222
223
224
225
226
227
228
229
230
	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(); };
	    }
231
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
232
233
    }
    else {
234
235
236
237
238
	require Net::SSL;
	require Net::HTTPS;
	$Net::HTTPS::SSL_SOCKET_CLASS = "Net::SSL";
	require LWP::UserAgent;
	
239
240
241
242
243
244
245
	#
	# 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.
	#
246
	if (!defined($context->password())) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
247
	    $ENV{'HTTPS_CERT_FILE'} = $context->certfile();
248
249
250
	    $ENV{'HTTPS_KEY_FILE'}  = $context->keyfile();
	}
	else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
251
	    $ENV{'HTTPS_PKCS12_FILE'}     = $context->certfile();
252
253
	    $ENV{'HTTPS_PKCS12_PASSWORD'} = $context->password();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
254
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
255
    my $request = new RPC::XML::request($method, @args);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
256
    if ($debug > 1) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
257
	print STDERR "xml request: $httpURL:" . $request->as_string();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
258
259
	print STDERR "\n";
    }
260
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
261
262
263
264
265
    #
    # Send an http post.
    #
    my $reqstr = $request->as_string();
    my $ua = LWP::UserAgent->new();
266
267
    $ua->timeout($timeout)
	if ($timeout > 0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
268
269
270
    my $hreq = HTTP::Request->new(POST => $httpURL);
    $hreq->content_type('text/xml');
    $hreq->content($reqstr);
271
    $hreq->protocol('HTTP/1.0')	if ($FBSD_MAJOR >= 8);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
272
273
    my $hresp = $ua->request($hreq);

Leigh B. Stoller's avatar
Leigh B. Stoller committed
274
275
276
277
278
279
280
    # 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
281
282
283
284
285
	print STDERR "xml response: " . $hresp->as_string();
	print STDERR "\n";
    }
    
    if (!$hresp->is_success()) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
286
287
	return GeniResponse->new(GENIRESPONSE_RPCERROR,
				 $hresp->code(), $hresp->message());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
288
289
290
291
292
293
294
    }

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
295
    if ($debug > 1) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
296
297
298
299
300
301
302
	print STDERR "xmlgoo: " . $xmlgoo;
	print STDERR "\n";
    }

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
308
309
310
311
312
313
314
315
316
    # 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'}))) {
317
	$code   = $goo->value()->{"faultCode"}->value;
318
	$value  = $goo->value()->{"faultCode"}->value;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
319
	$output = $goo->value()->{"faultString"}->value;
320
321
322
323
	# EXO returns a bad fault structure.
	if (!$code) {
	    $code = $value = GENIRESPONSE_ERROR();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
324
    }
325
326
327
328
329
330
331
    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
332
    else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
333
	$code   = $goo->value()->{'code'}->value;
334
335
336
337
338
339
	#
	# New SFA based AMs use a hash for the code. Why?
	#
	if (UNIVERSAL::isa($code,"HASH")) {
	    $code = $code->{'geni_code'};
	}
340
341
342
343
344
345
346
347
	#
	# Orca returns no value if there is a fault.
	#
	if (!defined($goo->value()->{'value'})) {
	    $value = undef;
	}
	else {
	    $value  = $goo->value()->{'value'}->value;
348
349
	    $logurl = $goo->value()->{'protogeni_error_url'}->value
		if (exists($goo->value()->{'protogeni_error_url'}));
350
	}
351
352
	$output = $goo->value()->{'output'}->value
	    if (exists($goo->value()->{'output'}));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
353
    }
354
    if ($debug > 1 && $code) {
355
356
	print STDERR "CallMethod: $method failed: $code";
	print STDERR ", $output\n" if (defined($output) && $output ne "");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
357
    }
358
    return GeniResponse->new($code, $value, $output, $logurl);
359

Leigh B. Stoller's avatar
Leigh B. Stoller committed
360
361
362
363
}

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