protogeni-wrapper.pl.in 13 KB
Newer Older
1
2
#!/usr/bin/perl -w
#
3
# GENIPUBLIC-COPYRIGHT
Leigh B Stoller's avatar
Leigh B Stoller committed
4
# Copyright (c) 2008-2012 University of Utah and the Flux Group.
5
6
7
8
# All rights reserved.
#

#
9
# Simple CGI interface to the GENI xmlrpc interface. This script is invoked
10
11
12
13
# from the web server. The certificate information is in the environment
# set up by apache.
#
use strict;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
14
use English;
15
use Frontier::Responder;
16
use Frontier::RPC2;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
17
use Data::Dumper;
18
use POSIX;
19
20
use Crypt::X509;
use Crypt::OpenSSL::X509;
21
use Time::HiRes qw( gettimeofday tv_interval );
22
23
24
25
26

# Yack. apache does not close fds before the exec, and if this dies
# we are left with a giant mess.
BEGIN {
    no warnings;
27
    for (my $i = 3; $i < 1024; $i++) {
28
29
30
      POSIX:close($i);
    }
}
31

32
# Configure variables
33
34
35
36
my $MAINSITE 	     = @TBMAINSITE@;
my $TBOPS            = "@TBOPSEMAIL@";
my $PORTAL_ENABLE    = @PORTAL_ENABLE@;
my $PORTAL_ISPRIMARY = @PORTAL_ISPRIMARY@;
37
38
39
my $MODULE;
my $GENIURN;

40
41
my $AM_MODULE = "am";

42
# These are the modules we load for each service.
43
44
45
46
my %GENI_MODULES = ( "cm"        => "@prefix@/lib/protogeni-cm.pm",
		     $AM_MODULE  => "@prefix@/lib/geni-am.pm",
		     "sa"        => "@prefix@/lib/protogeni-sa.pm",
		     "ch"        => "@prefix@/lib/protogeni-ch.pm",
47
48
		     "ses"       => "@prefix@/lib/protogeni-ses.pm",
		     # XXX This is temporary! 
Leigh B Stoller's avatar
Leigh B Stoller committed
49
50
		     "instools"  =>
		             "@prefix@/lib/instools/protogeni-instools.pm",
51
52
53
54
);
if ($PORTAL_ENABLE && !$PORTAL_ISPRIMARY) {
    $GENI_MODULES{"emulab"} = "@prefix@/lib/protogeni-emulab.pm";
}
55
56

# These variables are shared with the loaded module.
57
use vars qw($EMULAB_PEMFILE $GENI_METHODS $GENI_VERSION
Gary Wong's avatar
Gary Wong committed
58
	    $GENI_RESPONSE_CONVERTER $PROJECT);
59

60
61
# Testbed libraries.
use lib '@prefix@/lib';
62
use Genixmlrpc;
63
use GeniResponse;
64
use GeniHRN;
65
use GeniUtil;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
66
use libaudit;
Leigh B Stoller's avatar
Leigh B Stoller committed
67
use libEmulab;
68
use libtestbed;
69
use User;
70

71
# Need a command line option.
72
73
my $debug      = 0;
my $mailerrors = 1;
74
75
# Flag for XMLERROR.
my $logging    = 0;
76

77
78
79
# Determined by version.
my $responder;

80
81
82
83
84
85
86
87
88
89
90
#
# Turn off line buffering on output
#
$| = 1;

#
# Untaint the path
#
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

91
92
93
94
95
96
97
98
#
# Helper function to return a properly formated XML error.
#
sub XMLError($$)
{
    my ($code, $string) = @_;

    my $decoder = Frontier::RPC2->new();
Leigh B Stoller's avatar
Leigh B Stoller committed
99
    $string     = $decoder->encode_fault($code, $string);
100
101
102
103

    # Make sure the error goes back to user not into the debug file.
    LogEnd(0)
	if ($logging);
104
    print "Content-Type: text/xml \n\n";
105
    print $string;
106
107
108
    exit(0);
}

109
110
111
112
113
114
115
#
# Check for NoLogins; return XMLRPC
#
if (NoLogins()) {
    XMLError(503, "CM temporarily offline; please try again later");
}

116
117
118
119
120
121
122
#
# Check for excessive load
#
if ($MAINSITE) {
    my $uptime = `uptime`;
    if ($uptime =~ /load averages:\s+([\.\d]+),\s+([\.\d]+),\s+[\.\d]+/) {
	if ($1 > 10.0) {
123
	    XMLError(503, "Server is WAY too busy; please try again later");
124
125
126
127
	}
    }
}

128
129
130
131
132
133
134
135
136
137
138
139
140
#
# Make sure the client presented a valid certificate that apache says
# is okay.
#
# THIS HAS TO BE HERE! Why? Cause recent security patches disable SSL
# renegotiation, which is needed when a subdir turns on ssl client
# verification (as httpd.conf used to). Now, we set it to "optional",
# which avoids the renegotiation problem, but we have to make that
# this interface is always invoked by a client supplying a verifiable
# certificate. 
#
if (! (exists($ENV{'SSL_CLIENT_VERIFY'}) &&
       $ENV{'SSL_CLIENT_VERIFY'} eq "SUCCESS")) {
141
    XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid or missing certificate");
142
143
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
144
145
146
147
148
149
#
# In the prototype, we accept certificate signed by trusted roots
# (CA certs we have locally cached). This script runs as "geniuser"
# so that there is an emulab user context, or many of the scripts we
# invoke will complain and croak. 
#
150
GeniUtil::FlipToGeniUser();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
151

152
153
154
155
156
157
if (exists($ENV{'PATH_INFO'}) && $ENV{'PATH_INFO'} ne "") {
    my $pathinfo = $ENV{'PATH_INFO'};
    $pathinfo =~ s/^\///;
    my @parts = split(/\//, $pathinfo);
    if (@parts) {
	my $m = shift(@parts);
Gary Wong's avatar
Gary Wong committed
158
159
160
161
162
163
164
165
166
167
168
	if( $m eq "project" ) {
	    if (@parts) {
		my $p = shift(@parts);
		if ($p =~ /^[-\w]+$/) {
		    $PROJECT = "$p";
		}
		if (@parts) {
		    $m = shift(@parts);		
		}
	    }
	}
169
170
171
172
173
174
175
176
177
178
179
180
	if ($m =~ /^[-\w]+$/) {
	    $MODULE = $m;
	    if (@parts) {
		my $v = shift(@parts);
		if ($v =~ /^[\d\.]+$/) {
		    $GENI_VERSION = "$v";
		}
	    }
	}
    }
}

181
182
183
184
185
186
187
#
# The CERT data from apache holds the URN of the caller. 
#
if (exists($ENV{'SSL_CLIENT_CERT'})) {
    my $x509 = eval {
	Crypt::OpenSSL::X509->new_from_string($ENV{'SSL_CLIENT_CERT'}); };
    if ($@) {
188
	XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid certificate: $@");
189
190
    }
    my $cert = $x509->as_string(Crypt::OpenSSL::X509::FORMAT_ASN1);
191
192
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "Could not convert certificate to ASN1")
193
194
195
	if (!defined($cert) || $cert eq '');
    my $decoded = Crypt::X509->new( cert => $cert );
    if ($decoded->error) {
196
197
	XMLError(XMLRPC_APPLICATION_ERROR(),
		 "Error decoding certificate:" . $decoded->error);
198
199
    }
    foreach my $tmp (@{ $decoded->SubjectAltName }) {
200
201
	if ($tmp =~ /^uniformResourceIdentifier=(urn:publicid:.*)$/ ||
	    $tmp =~ /^(urn:publicid:.*)$/) {
202
	    $GENIURN = $ENV{'GENIURN'} = $1;
203
204
205
	}
    }
}
206
207
XMLError(XMLRPC_APPLICATION_ERROR(),
	 "Invalid authentication certificate; no URN. Please regenerate.")
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
    if (! (defined($GENIURN) && GeniHRN::IsValid($GENIURN)));

#
# Lets make sure that local users do not get past here if their account
# has been frozen. Their SSL certificate is still valid of course. We
# probably want to also add a check for non-local users, but that needs
# more thought.
#
my ($authority, $type, $id) = GeniHRN::Parse($GENIURN);
if ($type eq "user" && GeniHRN::Authoritative($GENIURN, "@OURDOMAIN@")) {
    #
    # Check Emulab users table. 
    #
    my $user = User->Lookup($id);
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "Not a valid local user. Who are you really?")
	if (!defined($user));
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "Your account is no longer active!")
	if ($user->status() ne "active");
}
229

Leigh B. Stoller's avatar
Leigh B. Stoller committed
230
231
232
233
234
235
236
237
#
# Reaching into the Frontier code so I can debug this crap.
#
my $request = Frontier::Responder::get_cgi_request();
if (!defined($request)) {
    print "Content-Type: text/txt\n\n";
    exit(0);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
238

239
if (!defined($MODULE) || !exists($GENI_MODULES{$MODULE})) {
240
    XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid module specification")
241
242
243
244
245
246
247
248
}
my $file = $GENI_MODULES{$MODULE};

# This just loads the file.
my $return = do $file;
if (!defined($return)) {
    SENDMAIL($TBOPS, "Error loading module",
	     ($@ ? $@ : ($! ? $! : Dumper(%ENV))));
249
    XMLError(XMLRPC_APPLICATION_ERROR(), "Internal error loading module");
250
251
252
253
}
if (!(defined($GENI_METHODS) && defined($EMULAB_PEMFILE))) {
    SENDMAIL($TBOPS, "Error loading module $MODULE",
	     "No definition for GENI_METHODS or EMULAB_PEMFILE");
254
255
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "Internal error loading module; missing definitions");
256
257
258
259
260
}

#
# So we know who/what we are acting as.
#
261
262
263
264
# Must be a require cause of the DB name that is set in the module file
# which is not loaded until just above.
require GeniCertificate;

265
my $certificate = GeniCertificate->LoadFromFile($EMULAB_PEMFILE);
Gary Wong's avatar
Gary Wong committed
266

267
268
269
270
if (!defined($certificate)) {
    die("*** $0:\n".
	"    Could not get uuid from $EMULAB_PEMFILE\n");
}
Gary Wong's avatar
Gary Wong committed
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286

if( $PROJECT ) {
    my $name = GeniHRN::Generate( "@OURDOMAIN@:$PROJECT", "authority",
				  $MODULE );
    my $authority = GeniAuthority->Lookup( $name );

    if (!defined($authority)) {
	die("*** $0:\n".
	    "    Could not resolve requested authority\n");
    }
    $ENV{'MYUUID'} = $authority->uuid();
    $ENV{'MYURN'}  = $authority->urn();
} else {
    $ENV{'MYUUID'} = $certificate->uuid();
    $ENV{'MYURN'}  = $certificate->urn();
}
287

288
289
290
#
# Create and set our RPC context for any calls we end up making.
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
291
Genixmlrpc->SetContext(Genixmlrpc->Context($certificate));
292

293
294
295
296
#
# Use libaudit to capture any output from libraries and programs.
# Send that to tbops so they can be fixed.
#
297
298
299
300
301
302
303
if ($MAINSITE) {
    LogStart(0);
    AddAuditInfo("to", "protogeni-errors\@flux.utah.edu")
}
else {
    LogStart(0, undef, LIBAUDIT_LOGTBOPS());
}
304
$logging = 1;
305

306
# CC errors to Utah for now.
307
AddAuditInfo("cc", "protogeni-errors\@flux.utah.edu");
308

309
310
311
312
313
314
315
316
317
#
# This is lifted from the Frontier code. I want the actual response
# object, not the XML. 
#
my $decoder   = Frontier::RPC2->new();
my $call;
my $response;

$request =~ s/(<\?XML\s+VERSION)/\L$1\E/;
318
$request =~ s/[^[:ascii:]]+//g;
319
320
eval { $call = $decoder->decode($request) };
if ($@) {
321
    XMLError(XMLRPC_PARSE_ERROR(), "error decoding RPC:\n" . "$@");
322
323
}
if ($call->{'type'} ne 'call') {
324
325
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "expected RPC methodCall, got $call->{'type'}");
326
327
328
}
my $method = $call->{'method_name'};
if (!defined($GENI_METHODS->{$method})) {
329
    XMLError(XMLRPC_APPLICATION_ERROR() + 3, "no such method $method\n");
330
}
331
332
333
334
335
336
337
338
339
340
341
342
343
344
# Strictly for debugging the CM.
my $target;
if (defined($call->{'value'})) {
    my ($argref) = @{ $call->{'value'} };
    if (ref($argref) eq "HASH") {
	if (exists($argref->{'slice_urn'})) {
	    $target = $argref->{'slice_urn'};
	}
	elsif (exists($argref->{'sliver_urn'})) {
	    $target = $argref->{'sliver_urn'};
	}
    }
}

345
346
my $result;
my $message =
347
348
349
350
    "URN:     $GENIURN\n";
$message .=
    "Target:  $target\n" if (defined($target));
$message .=
351
352
353
354
    "Module:  $MODULE\n".
    "Method:  $method\n";
$message .=
    "Version: $GENI_VERSION\n" if (defined($GENI_VERSION));
355
356
$message .=
    "Start:   " . TBTimeStamp() . "\n";
357

358
359
# Debug the CM and AM modules
if ($MODULE eq "cm" || $MODULE eq $AM_MODULE) {
Leigh B Stoller's avatar
Leigh B Stoller committed
360
    $debug = 0;
361
362
363
364
365
366
367

    # Too much output.
    if ($method eq "ListResources" ||
	$method eq "DiscoverResources") {
	$debug = 0;
    }
    # Happens too often and not interesting
Leigh B Stoller's avatar
Leigh B Stoller committed
368
369
370
    if ($method eq "Resolve" ||
	$method eq "SliverStatus" ||
	$method eq "GetVersion") {
371
372
373
374
375
376
377
378
379
	$debug = 0;
    }
    # We always want as much data as possible for these.
    if ($method eq "CreateSliver" ||
	$method eq "RedeemTicket" ||
	$method eq "GetTicket") {
	$debug = 2;
    }
}
380
381
382
elsif ($MODULE eq "emulab") {
    $debug = 2;
}
383

384
my $starttime = [gettimeofday()];
385
386
eval { $result = &{ $GENI_METHODS->{$method} }(@{ $call->{'value'} }) };
if ($@) {
387
388
389
    # In case the callee flipped.
    GeniUtil::FlipToGeniUser();
    
390
391
392
393
394
    #
    # These errors should get mailed to tbops.
    #
    print STDERR "Error executing RPC method $method:\n" . $@ . "\n";
    AddAuditInfo("to", $TBOPS);
395
396
    $response = $decoder->encode_fault(XMLRPC_SERVER_ERROR(),
				       "Internal Error executing $method");
397
398
399
400
401

    AddAuditInfo("message", $message .
		 "Error executing RPC:\n" . $@ . "\n\n" . $request);
}
else {
402
403
404
    # In case the callee flipped.
    GeniUtil::FlipToGeniUser();

405
    my $elapsed = tv_interval($starttime);
406
    $message .= "End:     " . TBTimeStamp() . "\n";
407
    $message .= "Elapsed: " . sprintf("%f", $elapsed) . "\n";
408
409
410

    if (!ref($result)) {
	$message .= "Return:    $result\n";
411
412
    }
    else {
413
414
415
416
417
418
419
	if (GeniResponse::IsError($result)) {
	    $message .= "Error:   " . $result->{'code'} . "\n";
	}
	else {
	    $message .= "Code:    " . $result->{'code'} . "\n";
	}
	$message .= "Output:  " . $result->{'output'} . "\n"
420
	    if (defined($result->{'output'}) && $result->{'output'} ne "");
421

422
423
424
425
426
427
	if (GeniResponse::IsError($result) || $debug > 1) {
	    $message .= "Result:\n"  . Dumper($result->{'value'}) . "\n\n";
	}
    }
    if (GeniResponse::IsError($result) || $debug > 1) {
	$message .= "Request:\n" . $request . "\n";
428
    }
429
    AddAuditInfo("message", $message);
430

431
432
433
434
435
    if (! ref($result)) {
	#
	# This could happen if the child forks. 
	#
	if ($result) {
436
	    print STDERR "Forked child returned an error\n";
437
	}
438
439
    }
    else {
440
441
442
443
444
445
446
447
448
449
450
451
	#
	# If the response indicates error, and no output is defined in
	# the response, then send back the contents of the audit file.
	# Not sure this makes any sense at all yet, but the point is to
	# get more info back to the user.
	#
	if (GeniResponse::IsError($result) &&
	    (!defined($result->{'output'}) || $result->{'output'} eq "") &&
	    exists($ENV{'TBAUDITLOG'}) && -s $ENV{'TBAUDITLOG'}) {
	    $result->{'output'} = `cat $ENV{'TBAUDITLOG'}`;
	}
	# Do this after above so that silly comment is not sent to user.
452
453
454
455
456
457
458
459
460
	if (GeniResponse::IsError($result)) {
	    if ($result->{'code'} == GENIRESPONSE_SEARCHFAILED() ||
		$result->{'code'} == GENIRESPONSE_BUSY) {
		# Do not send debugging mail for these two errors.
		$debug = 0;
	    }
	    elsif ($mailerrors) {
		print STDERR "Mail Errors is on.\n";
	    }
461
462
463
464
465
466
467
468
469
470
471
	}

	#
	# Added this for geni-am ...
	#
	if (defined($GENI_RESPONSE_CONVERTER)) {
	    $response = &$GENI_RESPONSE_CONVERTER($result);
	}
	else {
	    $response = $decoder->encode_response($result);
	}
472
    }
473
474
475
476
477
}

if ($debug) {
    print STDERR "Debugging is on.\n";
}
478

Leigh B. Stoller's avatar
Leigh B. Stoller committed
479
480
481
482
#
# Terminate the log capture so that we can print the response to STDOUT
# for the web server.
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
483
LogEnd(0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
484

485
486
print "Content-Type: text/xml \n\n" . $response
    if (defined($response));
487
exit(0);
488
489
490
491
492
493
494
495
496
497
498
499

#
# Want to prevent bad exit.
#
END {
    my $exitcode = $?;

    if ($exitcode) {
	LogEnd(0);

	my $decoder = Frontier::RPC2->new();
	print "Content-Type: text/xml \n\n";
500
501
	print $decoder->encode_fault(XMLRPC_SYSTEM_ERROR(),
				     "XMLRPC Server Error");
502
503
504
505
506
507

	# Since we converted to a normal error and sent the log message.
	$? = 0;
    }
}