protogeni-wrapper.pl.in 10.9 KB
Newer Older
1 2
#!/usr/bin/perl -w
#
3
# GENIPUBLIC-COPYRIGHT
4
# Copyright (c) 2008-2010 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
my $MAINSITE 	   = @TBMAINSITE@;
34 35 36 37
my $TBOPS          = "@TBOPSEMAIL@";
my $MODULE;
my $GENIURN;

38 39
my $AM_MODULE = "am";

40
# These are the modules we load for each service.
41 42 43 44 45
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",
		     "ses"       => "@prefix@/lib/protogeni-ses.pm" );
46 47

# These variables are shared with the loaded module.
48 49
use vars qw($EMULAB_PEMFILE $GENI_METHODS $GENI_VERSION
	    $GENI_RESPONSE_CONVERTER);
50

51 52
# Testbed libraries.
use lib '@prefix@/lib';
53
use Genixmlrpc;
54
use GeniResponse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
55
use libaudit;
Leigh B Stoller's avatar
Leigh B Stoller committed
56
use libEmulab;
57
use libtestbed;
58

Leigh B. Stoller's avatar
Leigh B. Stoller committed
59 60 61 62
# Geniuser.
my $user  = "geniuser";
my $group = "GeniSlices";

63
# Need a command line option.
64 65
my $debug      = 0;
my $mailerrors = 1;
66

67 68 69
# Determined by version.
my $responder;

70 71 72 73 74 75 76 77 78 79 80
#
# 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'};

81 82 83 84 85 86 87 88 89 90 91 92 93
#
# Helper function to return a properly formated XML error.
#
sub XMLError($$)
{
    my ($code, $string) = @_;

    my $decoder = Frontier::RPC2->new();
    print "Content-Type: text/xml \n\n";
    print $decoder->encode_fault($code, $string);
    exit(0);
}

94 95 96 97 98 99 100
#
# Check for NoLogins; return XMLRPC
#
if (NoLogins()) {
    XMLError(503, "CM temporarily offline; please try again later");
}

101 102 103 104 105 106 107
#
# Check for excessive load
#
if ($MAINSITE) {
    my $uptime = `uptime`;
    if ($uptime =~ /load averages:\s+([\.\d]+),\s+([\.\d]+),\s+[\.\d]+/) {
	if ($1 > 10.0) {
108
	    XMLError(503, "Server is WAY too busy; please try again later");
109 110 111 112
	}
    }
}

113 114 115 116 117 118 119 120 121 122 123 124 125
#
# 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")) {
126
    XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid or missing certificate");
127 128
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
#
# 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. 
#
my $unix_uid = getpwnam("$user") or
    die("*** $0:\n".
	"    No such user $user\n");
my $unix_gid = getgrnam("$group") or
    die("*** $0:\n".
	"    No such group $group\n");

# Flip to user and never go back
$GID            = $unix_gid;
$EGID           = "$unix_gid $unix_gid";
$EUID = $UID    = $unix_uid;
$ENV{'USER'}    = $user;
$ENV{'LOGNAME'} = $user;

149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
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);
	if ($m =~ /^[-\w]+$/) {
	    $MODULE = $m;
	    if (@parts) {
		my $v = shift(@parts);
		if ($v =~ /^[\d\.]+$/) {
		    $GENI_VERSION = "$v";
		}
	    }
	}
    }
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
167 168 169 170 171 172 173 174 175 176
#
# The UUID of the client certificate is in the env var SSL_CLIENT_S_DN_CN.
# If it actually looks like a UUID, then this correponds to an actual user,
# and the supplied credentials/tickets must match. At present, if there is
# no UUID, it is another emulab making a request directly, with no user
# context, and we just let that pass for now.
#
if (exists($ENV{'SSL_CLIENT_S_DN_CN'}) &&
    $ENV{'SSL_CLIENT_S_DN_CN'} =~ /^\w+\-\w+\-\w+\-\w+\-\w+$/) {
    $ENV{'GENIUSER'} = $ENV{'SSL_CLIENT_S_DN_CN'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
177
    $ENV{'GENIUUID'} = $ENV{'SSL_CLIENT_S_DN_CN'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
178
}
179 180 181
elsif (defined($MODULE) && ($MODULE eq $AM_MODULE)) {
    # Do not expect a UUID if calling to the AM.
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
182
else {
183
    XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid certificate; no UUID");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
184
}
185 186 187 188 189 190 191 192

#
# 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 ($@) {
193
	XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid certificate: $@");
194 195
    }
    my $cert = $x509->as_string(Crypt::OpenSSL::X509::FORMAT_ASN1);
196 197
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "Could not convert certificate to ASN1")
198 199 200
	if (!defined($cert) || $cert eq '');
    my $decoded = Crypt::X509->new( cert => $cert );
    if ($decoded->error) {
201 202
	XMLError(XMLRPC_APPLICATION_ERROR(),
		 "Error decoding certificate:" . $decoded->error);
203 204
    }
    foreach my $tmp (@{ $decoded->SubjectAltName }) {
205 206
	if ($tmp =~ /^uniformResourceIdentifier=(urn:publicid:.*)$/ ||
	    $tmp =~ /^(urn:publicid:.*)$/) {
207
	    $GENIURN = $ENV{'GENIURN'} = $1;
208 209 210
	}
    }
}
211 212
XMLError(XMLRPC_APPLICATION_ERROR(),
	 "Invalid authentication certificate; no URN. Please regenerate.")
213 214
    if (!exists($ENV{'GENIURN'}));

Leigh B. Stoller's avatar
Leigh B. Stoller committed
215 216 217 218 219 220 221 222
#
# 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
223

224
if (!defined($MODULE) || !exists($GENI_MODULES{$MODULE})) {
225
    XMLError(XMLRPC_APPLICATION_ERROR(), "Invalid module specification")
226 227 228 229 230 231 232 233
}
my $file = $GENI_MODULES{$MODULE};

# This just loads the file.
my $return = do $file;
if (!defined($return)) {
    SENDMAIL($TBOPS, "Error loading module",
	     ($@ ? $@ : ($! ? $! : Dumper(%ENV))));
234
    XMLError(XMLRPC_APPLICATION_ERROR(), "Internal error loading module");
235 236 237 238
}
if (!(defined($GENI_METHODS) && defined($EMULAB_PEMFILE))) {
    SENDMAIL($TBOPS, "Error loading module $MODULE",
	     "No definition for GENI_METHODS or EMULAB_PEMFILE");
239 240
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "Internal error loading module; missing definitions");
241 242 243 244 245 246 247 248 249 250 251
}

#
# So we know who/what we are acting as.
#
my $certificate = GeniCertificate->LoadFromFile($EMULAB_PEMFILE);
if (!defined($certificate)) {
    die("*** $0:\n".
	"    Could not get uuid from $EMULAB_PEMFILE\n");
}
$ENV{'MYUUID'} = $certificate->uuid();
252
$ENV{'MYURN'}  = $certificate->urn();
253

254 255 256
#
# Create and set our RPC context for any calls we end up making.
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
257
Genixmlrpc->SetContext(Genixmlrpc->Context($certificate));
258

259 260 261 262
#
# Use libaudit to capture any output from libraries and programs.
# Send that to tbops so they can be fixed.
#
263 264 265 266 267 268 269
if ($MAINSITE) {
    LogStart(0);
    AddAuditInfo("to", "protogeni-errors\@flux.utah.edu")
}
else {
    LogStart(0, undef, LIBAUDIT_LOGTBOPS());
}
270

271
# CC errors to Utah for now.
272
AddAuditInfo("cc", "protogeni-errors\@flux.utah.edu");
273

274 275 276 277 278 279 280 281 282 283 284
#
# 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/;
eval { $call = $decoder->decode($request) };
if ($@) {
285
    XMLError(XMLRPC_PARSE_ERROR(), "error decoding RPC:\n" . $@);
286 287
}
if ($call->{'type'} ne 'call') {
288 289
    XMLError(XMLRPC_APPLICATION_ERROR(),
	     "expected RPC methodCall, got $call->{'type'}");
290 291 292
}
my $method = $call->{'method_name'};
if (!defined($GENI_METHODS->{$method})) {
293
    XMLError(XMLRPC_APPLICATION_ERROR() + 3, "no such method $method\n");
294
}
295 296 297 298 299 300 301 302 303 304 305 306 307 308
# 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'};
	}
    }
}

309 310
my $result;
my $message =
311 312 313 314
    "URN:     $GENIURN\n";
$message .=
    "Target:  $target\n" if (defined($target));
$message .=
315 316 317 318
    "Module:  $MODULE\n".
    "Method:  $method\n";
$message .=
    "Version: $GENI_VERSION\n" if (defined($GENI_VERSION));
319 320

my $starttime = [gettimeofday()];
321 322 323 324 325 326 327
eval { $result = &{ $GENI_METHODS->{$method} }(@{ $call->{'value'} }) };
if ($@) {
    #
    # These errors should get mailed to tbops.
    #
    print STDERR "Error executing RPC method $method:\n" . $@ . "\n";
    AddAuditInfo("to", $TBOPS);
328 329
    $response = $decoder->encode_fault(XMLRPC_SERVER_ERROR(),
				       "Internal Error executing $method");
330 331 332 333 334

    AddAuditInfo("message", $message .
		 "Error executing RPC:\n" . $@ . "\n\n" . $request);
}
else {
335 336 337
    my $elapsed = tv_interval($starttime);
    $message .= "Elapsed: " . sprintf("%f", $elapsed) . "\n";
    
338
    if (GeniResponse::IsError($result)) {
339
	$message .= "Error:   " . $result->{'code'} . "\n";
340 341
    }
    else {
342
	$message .= "Code:    " . $result->{'code'} . "\n";
343
    }
344
    $message .= "Output:  " . $result->{'output'} . "\n"
345 346 347 348 349 350
	if (defined($result->{'output'}));

    $message .= "Result:\n"  . Dumper($result->{'value'}) . "\n\n";
    $message .= "Request:\n" . $request . "\n";
    
    AddAuditInfo("message", $message);
351

352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
    #
    # 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.
    if (GeniResponse::IsError($result) && $mailerrors &&
	$result->{'code'} != GENIRESPONSE_SEARCHFAILED()) {
	print STDERR "Mail Errors is on.\n";
    }

369 370 371 372 373 374 375 376 377
    #
    # Added this for geni-am ...
    #
    if (defined($GENI_RESPONSE_CONVERTER)) {
	$response = &$GENI_RESPONSE_CONVERTER($result);
    }
    else {
	$response = $decoder->encode_response($result);
    }
378 379 380 381 382
}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
384 385 386 387
#
# 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
388
LogEnd(0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
389

Leigh B. Stoller's avatar
Leigh B. Stoller committed
390
print "Content-Type: text/xml \n\n" . $response;
391
exit(0);
392 393 394 395 396 397 398 399 400 401 402 403

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

    if ($exitcode) {
	LogEnd(0);

	my $decoder = Frontier::RPC2->new();
	print "Content-Type: text/xml \n\n";
404 405
	print $decoder->encode_fault(XMLRPC_SYSTEM_ERROR(),
				     "XMLRPC Server Error");
406 407 408 409 410 411

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