GeniCM.pm.in 240 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1 2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2008-2017 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 39
#
package GeniCM;

#
# The server side of the CM interface on remote sites. Also communicates
# with the GMC interface at Geni Central as a client.
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

40 41
@ISA    = qw(Exporter);
@EXPORT = qw();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42 43 44

use GeniDB;
use Genixmlrpc;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
45 46
use GeniResponse;
use GeniTicket;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
use GeniCredential;
48
use GeniCertificate;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
49
use GeniSlice;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
50
use GeniAggregate;
51
use GeniAuthority;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52
use GeniSliver;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
53
use GeniUser;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
54
use GeniRegistry;
55
use GeniUtil;
56
use GeniHRN;
57
use GeniXML;
58
use GeniStitch;
59
use GeniUsage;
60
use GeniImage;
61
use libtestbed;
62
use emutil;
63
use EmulabConstants;
64
use EmulabFeatures;
65
use libEmulab;
66
use Lan;
67
use User;
68
use Experiment;
69
use NodeType;
70
use Node;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
71 72
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
73
use XML::Simple;
74
use XML::LibXML;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
75
use Date::Parse;
76
use POSIX qw(strftime ceil);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
77
use Time::Local;
78
use Compress::Zlib;
79
use File::Temp qw(tempfile tmpnam);
80
use MIME::Base64;
81
use Digest::SHA1 qw(sha1_hex);
82
use POSIX ":sys_wait_h";
Leigh B Stoller's avatar
Leigh B Stoller committed
83
use Errno qw(:POSIX);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
84 85 86 87 88 89

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
90 91
my $TBBASE         = "@TBBASE@";
my $TBDOCBASE      = "@TBDOCBASE@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
92 93
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
94
my $MAINSITE       = @TBMAINSITE@;
95
my $ELABINELAB     = @ELABINELAB@;
96
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
97
my $PROTOUSER 	   = "elabman";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
98
my $CREATEEXPT     = "$TB/bin/batchexp";
99
my $ENDEXP         = "$TB/bin/endexp";
100
my $NFREE	   = "$TB/bin/nfree";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
101
my $AVAIL	   = "$TB/sbin/avail";
102
my $PTOPGEN	   = "$TB/libexec/ptopgen";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
103 104
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
105 106
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
107
my $EXPORTS_SETUP  = "$TB/sbin/exports_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
108 109
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
110
my $IPASSIGN       = "$TB/libexec/ipassign_wrapper";
111
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
112 113
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
114
my $SNMPIT         = "$TB/bin/snmpit";
115
my $RESERVEVLANS   = "$TB/sbin/protogeni/reservevlans";
116
my $NEWGROUP       = "$TB/bin/newgroup";
117 118
my $NEWPROJECT     = "$TB/sbin/newproj";
my $MAKEPROJECT    = "$TB/sbin/mkproj";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
119
my $PRERENDER      = "$TB/libexec/vis/prerender";
120 121
my $SUDO           = "/usr/local/bin/sudo";
my $WAP            = "$TB/sbin/withadminprivs";
122
my $XMLLINT	   = "/usr/local/bin/xmllint";
123
my $ADDAUTHORITY   = "$TB/sbin/protogeni/addauthority";
124
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
125
my $TARINSTALL     = "/usr/local/bin/install-tarfile";
126
my $IMAGE_SETUP    = "$TB/sbin/image_setup";
127
my $IMAGE_IMPORT   = "$TB/sbin/image_import";
128
my $SHAREVLAN      = "$TB/sbin/sharevlan";
129
my $RFLINKS	   = "$TB/bin/rflinks";
130
my $FWNAME	   = "fw";
131
my $API_VERSION    = 1;
132 133
my $PROTOGENI_LOCALUSER   = @PROTOGENI_LOCALUSER@;
my $PROTOGENI_NONFSMOUNTS = @PROTOGENI_NONFSMOUNTS@;
134

135 136 137 138 139
# For location info.
my $default_longitude = undef;
my $default_latitude  = undef;
my $default_country   = undef;

140 141 142 143 144 145 146 147 148 149
#
# Tell the client what API revision we support.  The correspondence
# between revision numbers and API features is to be specified elsewhere.
# No credentials are required.
#
sub GetVersion()
{
    return GeniResponse->Create( GENIRESPONSE_SUCCESS, $API_VERSION );
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
150
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
151
# Respond to a Resolve request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
152 153 154 155 156 157
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
158 159
    my $type       = lc( $argref->{'type'} );
    my $hrn        = $argref->{'hrn'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
160 161 162 163

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
164 165 166 167
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
168 169 170 171 172 173 174 175 176 177 178 179
    if( defined( $hrn ) && GeniHRN::IsValid( $hrn ) ) {
	my ($auth,$t,$id) = GeniHRN::Parse( $hrn );

	return GeniResponse->Create( GENIRESPONSE_ERROR, undef,
				     "Authority mismatch" )
	    if( $auth ne $OURDOMAIN );

	$type = lc( $t );
	
	$hrn = $id;	
    }
    if (! (defined($type) && ($type =~ /^(node)$/))) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
180 181 182
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
183
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
184 185 186 187 188 189
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

190
    my $credential = GeniCredential::CheckCredential($cred);
191 192 193
    return $credential
	if (GeniResponse::IsResponse($credential));

194
    if ($type eq "node") {
195
	require Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
196 197 198
	my $node;
	
	if (defined($uuid)) {
199
	    $node= GeniUtil::LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
200 201
	}
	else {
202
	    $node= GeniUtil::LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
203
	}
204
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
205 206 207
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
208

209
	my $rspec = GetAdvertisement(0, $node->node_id(), "0.1", undef);
210 211 212 213
	if (! defined($rspec)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not start avail");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
214 215
	
	# Return a blob.
216
	my $blob = { "hrn"          => "${PGENIDOMAIN}." . $node->node_id(),
Leigh B. Stoller's avatar
Leigh B. Stoller committed
217
		     "uuid"         => $node->uuid(),
218
		     "role"	    => $node->role(),
219 220
		     "hostname"     =>
			 GeniUtil::FindHostname($node->node_id()),
221 222
		     "physctrl"     => 
			 Interface->LookupControl( $node->phys_nodeid() )->IP(),
223 224
		     "urn"          => GeniHRN::Generate( $OURDOMAIN,
							  "node",
225 226
							  $node->node_id() ),
		     "rspec"        => $rspec
Leigh B. Stoller's avatar
Leigh B. Stoller committed
227 228 229 230 231 232 233
		   };

	return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
    }
    return GeniResponse->Create(GENIRESPONSE_UNSUPPORTED);
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
234 235 236 237 238 239
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
240
    my $credstr   = $argref->{'credential'};
241
    my $available = $argref->{'available'} || 0;
242
    my $compress  = $argref->{'compress'} || 0;
243
    my $version   = $argref->{'rspec_version'} || undef;
244

245
    my $credential = GeniCredential::CheckCredential($credstr);
246 247
    return $credential
	if (GeniResponse::IsResponse($credential));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
248

249 250
    return DiscoverResourcesAux($available,
				$compress, $version, [$credential]);
251 252
}
# Helper function for V2.
253
sub DiscoverResourcesAux($$$$)
254
{
255
    my ($available, $compress, $version, $credentials) = @_;
256
    my $user_urn  = $ENV{'GENIRN'};
257
    $version   = "2"
258 259 260
	if (!defined($version));

    # Sanity check since this can come from client.
261
    if (! ($version eq "0.1" || $version eq "0.2" || $version eq "2"
262 263 264
	   || $version eq "3"
	   || $version eq "PG 0.1" || $version eq "PG 0.2"
	   || $version eq "PG 2")) {
265 266 267
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper version request");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
268

269 270 271
    # Oh, for $*%(s sake.  Frontier::RPC2 insists on representing a
    # Boolean as its own object type -- which Perl always interprets as
    # true, regardless of the object's value.  Undo all of that silliness.
272 273 274 275 276 277
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
278

Leigh B. Stoller's avatar
Leigh B. Stoller committed
279 280 281 282
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
283
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
284 285
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
286
    }
287 288 289 290 291 292 293

    # Figure out if user has a credentials that exempts him
    # from the following policy. If external users are blocked access
    # and he presents a credential that exempts him from it, 
    # then he should get access.
    my $isExempted = 0;
    foreach my $credential (@$credentials) {
294
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
295 296 297 298 299 300
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
301
	my $user = GeniUser->Lookup($user_urn, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
302 303 304 305 306 307 308
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327
    #
    # See if one of the credentials is a slice credential. If it is, and
    # that slice is active, pass it to ptopgen so that it includes the current
    # resources as available.
    #
    my $experiment = undef;
    foreach my $credential (@$credentials) {
	my ($auth, $type, $id) = GeniHRN::Parse($credential->target_urn());
	if ($type eq "slice") {
	    # Might not exist here yet.
	    my $slice = GeniSlice->Lookup($credential->target_urn());
	    if (defined($slice)) {
		# See if the local experiment exists yet.
		$experiment = Experiment->Lookup($slice->uuid());
	    }
	    last;
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
328
    #
329
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
330
    #
331
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
332
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
333 334 335 336
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

337 338 339 340 341 342
    if( $compress ) {
	my $coder = Frontier::RPC2->new();
	my $base64 = encode_base64( compress( $xml ) );
	$xml = $coder->base64( $base64 );	
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
343 344
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
345

346 347 348
#
# Use ptopgen in xml mode to spit back an xml file. 
#
349
sub GetAdvertisement($$$$)
350
{
351
    my ($available, $pc, $version, $experiment) = @_;
352
    my $xml = undef;
353 354
    my $gotlock = 0;
    my $filename = "/var/tmp/protogeni_resources.xml";
355

356 357 358 359 360 361 362
    $version = "0.1"
	if ($version eq "PG 0.1");
    $version = "0.2"
	if ($version eq "PG 0.2");
    $version = "2"
	if ($version eq "PG 2");

363
    my $invocation = "$PTOPGEN -x -g $version -r -f";
364 365
    if (defined($experiment)) {
	my $eid = $experiment->eid();
366
	my $pid = $experiment->pid();
367
	$invocation .= " -p $pid -e $eid";
368
    }
369 370 371 372
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
    if (!defined($pc)) {
      again:
	#
	# Grab a global script lock. This will ensure that only one ptopgen
	# runs at a time, and everyone else who comes along while that first
	# one is running, will share the same results file.
	#
	# Need to use a well known name, unless we want to share that name
	# via the DB. Lets be simple about it for now.
	#
	if ((my $locked = TBScriptLock("discover", 1)) != TBSCRIPTLOCK_OKAY()) {
	    if ($locked == TBSCRIPTLOCK_IGNORE) {
		#
		# Previous locker finished ptopgen.
		# Grab the file if it exists (small race), otherwise
		# try again from the top.
		#
		if (open(AVAIL, "$filename")) {
		    $xml = "";
		    while (<AVAIL>) {
			$xml .= $_;
		    }
		    close(AVAIL);
		    return $xml;
		}
		goto again;
	    }
	    else {
		print STDERR "Could not get ptopgen lockfile\n";
		return undef;
	    }
	}
	else {
	    #
	    # We got the lock so we get to run ptopgen.
	    #
	    $gotlock = 1;
	}
    }
412
    if (open(AVAIL, "$invocation |")) {
413
	$xml = "";
414 415 416 417 418
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
    #
    # The lock holder has to create the new version of the file for
    # anyone waiting. Need to do this atomically so that anyone still
    # reading the previous version does not get inconsistent data.
    #
    if ($gotlock) {
	my ($fh, $tempname) = tempfile(UNLINK => 0, DIR => "/var/tmp");
	if (!defined($fh)) {
	    print STDERR "Could not create temporary file: $!\n";
	    $xml = undef;
	}
	else {
	    print $fh $xml;
	    close($fh);
	    if (! rename($tempname, $filename)) {
		print STDERR "Could not rename temporary file: $!\n";
		$xml = undef;
	    }
	}
	TBScriptUnlock();
    }
440 441 442
    return $xml;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
443
#
444
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
445
#
446
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
447 448
{
    my ($argref) = @_;
449 450 451 452 453 454 455 456 457 458

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
459
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
460
    my $impotent   = $argref->{'impotent'};
461 462
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
463 464 465 466 467 468 469
    my $ticket;

    # Default to no update
    $isupdate = 0
	if (!defined($isupdate));
    $impotent = 0
	if (!defined($impotent));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
470

471
    if (! defined($credstr)) {
472
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
473
    }
474
    if (!defined($rspecstr)) {
475 476
	return GeniResponse->MalformedArgsResponse();
    }
477 478 479 480
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
481
    my $credential = GeniCredential::CheckCredential($credstr);
482 483 484
    return $credential
	if (GeniResponse::IsResponse($credential));

485
    if ($isupdate) {
486
	$ticket = CheckTicket($tickstr, $credential->target_urn());
487 488
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
489
    }
490
    return GetTicketAux($credential,
491
			$rspecstr, $isupdate, $impotent, 0, 1, 0, $ticket);
492
}
493

494
sub GetTicketAux($$$$$$$$$@)
495
{
496
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level, $usetracker,
497
	$ticket, $speaksfor, @morecreds) = @_;
498
    
499 500 501 502 503 504
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
505
    
506 507
    my $slice_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
508
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
509
    #
510
    # Create user from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
511
    #
512
    my $user = CreateUserFromCertificate($credential);
513 514
    return $user
	if (GeniResponse::IsResponse($user));
515 516 517

    # Bump activity. Does not matter if request fails ...
    $user->BumpActivity();
518
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
519
    #
520
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
521
    #
522 523
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
524
	if ($isupdate) {
525
	    print STDERR "Could not locate slice $slice_urn for Update\n";
526
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
527 528 529
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
530 531
	return $slice
	    if (GeniResponse::IsResponse($slice));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
532
    }
533 534 535
    $slice->SetSpeaksFor($speaksfor)
	if (defined($speaksfor));
	
536
    main::AddLogfileMetaDataFromSlice($slice);
537
    
538
    return GetTicketAuxAux($slice, $user, $rspecstr,
539 540
			   $isupdate, $impotent, $v2, $level, $usetracker,
			   $ticket, [$credential, @morecreds], $speaksfor);
541
}
542
sub GetTicketAuxAux($$$$$$$$$$$)
543
{
544
    my ($slice, $user, $rspecstr, $isupdate,
545 546
	$impotent, $v2, $level, $usetracker,
	$ticket, $credentials, $speaksfor) = @_;
547 548 549
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
550
    require OSImage;
551
    require VirtExperiment;
552 553 554 555 556 557

    #
    # We need this below to sign the ticket.
    #
    my $authority = GeniCertificate->LoadFromFile($EMULAB_PEMFILE);
    if (!defined($authority)) {
558
	print STDERR " Could not load authority for $EMULAB_PEMFILE\n";
559 560 561
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
    #
    # Run xmllint on the rspec to catch format errors.
    #
    my ($fh, $filename) = tempfile(UNLINK => 0);
    if (!defined($fh)) {
	print STDERR "Could not create temp file for rspec\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    print $fh $rspecstr;
    close($fh);
    my $xmlerrors = `$XMLLINT --noout $filename 2>&1`;
    unlink($filename);
    if ($?) {
	return GeniResponse->Create(GENIRESPONSE_ERROR,
				    $xmlerrors,
				    "rspec is not well formed");
    }

580 581
    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
582
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
583
				    "Error Parsing rspec XML");
584
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
585

586 587 588 589 590 591
    my $rspecVersion = GeniXML::GetXmlVersion($rspec);
    if (! defined($rspecVersion)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Unknown RSpec Version");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
592 593 594 595
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
596
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
597 598 599 600
	    # Cannot get the value, say no.
	    $allow_externalusers = 0;
    }

601 602 603 604 605 606 607 608 609 610 611
    # Image tracker.
    my $use_imagetracker;
    if (!GetSiteVar('protogeni/use_imagetracker', \$use_imagetracker)) {
	# Cannot get the value, say no.
	$use_imagetracker = 0;
    }
    # But the Portal is currently the one telling us to use the tracker
    # for specific slices.
    $use_imagetracker = 1
	if ($use_imagetracker && $usetracker);

612 613 614 615
    #
    # Watch for sites that do not support openflow, we want to fail early.
    #
    my $no_openflow = 0;
616
    my $ignore_openflow = 0;
617 618 619 620
    if (!GetSiteVar('general/no_openflow', \$no_openflow)){
	# Cannot get the value, say no.
	$no_openflow = 1;
    }
621 622 623 624
    if ($no_openflow =~ /ignore/) {
	$no_openflow = 1;
	$ignore_openflow = 1;
    }
625

626 627 628 629 630 631 632 633 634 635
    # Figure out if user has a credentials that exempts him
    # from the following policy. If external users are blocked access
    # and he presents a credential that exempts him from it, 
    # then he should get access.
    my $isExempted = 0;
    foreach my $credential (@$credentials) {
      if (1 == GeniXML::PolicyExists('allow_externalusers', $credential)) {
        $isExempted = 1;
        last;
      }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
636
    }
637 638 639

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
640 641 642 643
				    "External users temporarily denied");
    }
    
    #
644
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
645
    # ticket is redeemed, it will expire according to the rspec request.
646 647
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
648 649
    # slice credential, or the local policy max_sliver_lifetime. See
    # CreateSliceFromCertificate() in this file.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
650
    #
Jonathon Duerig's avatar
Jonathon Duerig committed
651
    my $expires = GeniXML::GetExpires($rspec);
652
    if (defined($expires)) {
653 654
	if (GeniResponse::IsResponse($expires)) {
	    return $expires;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
655
	}
656 657
	# Note "checkonly" flag; we do not actually change the slice
	# until the ticket is redeemed. 
658
	my $tmp = SetSliceExpiration($slice, $expires, 1, 0, @{ $credentials });
659 660
	if (GeniResponse::IsResponse($tmp)) {
	    return $tmp;
661
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
662
    }
663 664 665 666 667 668 669

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
670 671 672
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
673 674 675 676 677 678
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
679 680 681
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
682
    }
683 684 685
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
686 687
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
688 689 690
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
691 692 693 694 695 696 697 698
    # Ditto for expired.
    if ($slice->IsExpired()) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->Create(GENIRESPONSE_REFUSED, undef,
				    "Slice has expired");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
699

700
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
701
    # For now, there can be only a single toplevel aggregate per slice.
702
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
703
    #
704
    my $aggregate = GeniAggregate->SliceAggregate($slice);
705 706 707 708 709
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
710 711
	}
    }
712
    elsif ($v2 && $level > 0 && !defined($ticket) && !defined($aggregate)) {
713 714 715 716
	print STDERR "No aggregate for $slice in version two API\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
717

718
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
719
    # We need this now so we can form a virtual topo.
720
    #
721 722 723 724 725 726
    my $slice_experiment = GeniExperiment($slice, $user);
    if (GeniResponse::IsResponse($slice_experiment)) {
	$response = $slice_experiment;
	$slice_experiment = undef;
	goto bad;
    }
727 728 729 730
    #
    # Mark the expires slot in the experiment, for admission control
    # during the mapper run. 
    #
Leigh B Stoller's avatar
Leigh B Stoller committed
731 732 733 734 735 736 737 738 739 740 741 742 743 744
    # Convert to a localtime.
    #
    if (defined($expires)) {
	$expires = eval { timegm(strptime($expires)); };
	if ($@ || !defined($expires)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Could not parse expiration");
	    goto bad;
	}
    }
    else {
	$expires = $slice->expires();
    }
    if ($slice_experiment->SetExpiration($expires)) {
745 746 747 748 749
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "set experiment expiration");
	print STDERR "Could not set experiment expiration\n";
	goto bad;
    }
750 751 752 753 754
    my $realuser = FlipToUser($slice, $user);
    if (! (defined($realuser) && $realuser)) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "FlipToUser Error");
	print STDERR "Error flipping to real user\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
755 756 757 758
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
759 760 761 762 763

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
764
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
765 766
    if (defined($generated_by) &&
	$generated_by eq "libvtop") {
767 768 769 770
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
771 772 773 774 775 776 777 778 779 780 781 782 783
    
    #
    # Create a virt topology object. We are going to load this up as we
    # process the rspec.
    #
    my $virtexperiment = VirtExperiment->CreateNew($slice_experiment);
    if (!defined($virtexperiment)) {
	print STDERR "Could not create VirtExperiment object!\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    # Turn off fixnode; we will control this on the commandline.
    $virtexperiment->allowfixnode(0);
784 785 786 787

    #
    # Allow user to control the multiplex factor. Note that ptopgen
    # will not allow the mfactor to be more then what we set as the
788 789 790 791 792 793 794 795 796 797 798 799 800 801
    # max for the node, but in general we set it low here. Also note
    # that to support Emulab Classic NS file conversion, zero means to
    # not change it.
    #
    my $mfactor = GeniXML::MultiplexFactor($rspec);
    if (defined($mfactor)) {
	if ($mfactor != 0) {
	    $virtexperiment->multiplex_factor($mfactor);
	}
    }
    else {
	# Odd geni default dating back to the beginning of time.
	$virtexperiment->multiplex_factor(10);
    }
802 803 804 805 806
    #
    # The packing strategy is sorta independent; the user can specify either
    # pack or balance (load balance).
    #
    my $packing_option = GeniXML::PackingStrategy($rspec);
807

808 809 810 811 812
    #
    # Global root keys disable.
    #
    my $disablerootkeys = GeniXML::DisableRootKey($rspec);

813
    #
814
    # User can turn off routing.
815
    #
816 817 818 819 820 821 822 823 824 825 826 827
    my $routertype = GeniXML::RoutingStyle($rspec);
    if (!defined($routertype)) {
	$routertype = "static-ddijk";
    }
    elsif ($routertype eq "static") {
	$routertype = "static-ddijk";
    }
    elsif ($routertype ne "none") {
	$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad routing style: $routertype");
	goto bad;
    }
828
    
829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854
    #
    # User can set the delay image. 
    #
    if (defined(GeniXML::DelayImage($rspec))) {
	my $delayurn = GeniXML::DelayImage($rspec);
	
	if (!GeniHRN::IsValid($delayurn)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid URN: $delayurn");
	    goto bad;
	}
	my $hrn = GeniHRN->new($delayurn);
	my (undef,$ospid,$os,$vers) = $hrn->ParseImage();
	if ($hrn->type() ne "image" || !defined($ospid) || !defined($os)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Malformed image URN: $delayurn");
	    goto bad;
	}
	my $delayname = $os;
	$delayname = "${ospid}/" . $delayname
	    if (defined($ospid));
	$delayname .= ":${vers}"
	    if (defined($vers));
	
	$virtexperiment->delay_osname($delayname);
    }
855

856 857 858 859 860 861 862 863 864 865
    #
    # Add global vtypes.
    #
    my $vtypes_result =
	emdb::DBQueryWarn("select * from global_vtypes");
    if (!$vtypes_result) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    while (my $row = $vtypes_result->fetchrow_hashref()) {
866
	$virtexperiment->NewTableRow("virt_vtypes",
867 868 869 870
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
871
    }
872

873 874 875 876 877
    # Need to move this someplace else; the parser adds a bunch.
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "ns",
				  "objecttype" => "6"});
878 879 880 881
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "linktest",
				  "objecttype" => "7"});
882

883 884 885
    #
    # Look for toplevel address pools
    #
886 887 888 889 890 891 892
    if (Node::HaveExperimentNodes()) {
	my $address_pools = GeniXML::GetAddressPools($rspec);
	foreach my $pool (@{ $address_pools }) {
	    if (! defined($pool->{'cmurn'}) ||
		$pool->{'cmurn'} eq $ENV{'MYURN'})
	    {
		if ($pool->{'type'} ne "any") {
893
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
894 895 896 897 898
		     "Only public address pools of type any are supported");
		    goto bad;
		}
		print STDERR 'DEBUG: Adding row to virt_address_allocation';
		$virtexperiment->NewTableRow("virt_address_allocation",
899 900 901 902
					 {"pool_id" => $pool->{'client_id'},
					  "count" => $pool->{'count'},
					  "restriction" => $pool->{'type'},
					  "version" => "ipv4" });
903
	    }
904 905 906
	}
    }

907 908 909 910 911 912 913 914 915 916 917 918
    #
    # Look for toplevel elabinelab section.
    #
    my $elabinelab_settings = GeniXML::GetElabInElabSettings($rspec);
    if (defined($elabinelab_settings)) {
	$virtexperiment->elab_in_elab(1);
	if (exists($elabinelab_settings->{'singlenet'})) {
	    $virtexperiment->elabinelab_singlenet(1);
	}
	if (exists($elabinelab_settings->{'xen'})) {
	    $virtexperiment->multiplex_factor(2);
	}
919
    }
920 921 922 923
    #
    # Note that we set the mounts to "genidefault" when we create the
    # container experiment. So this overrides.
    #
924 925
    if ($PROTOGENI_NONFSMOUNTS) {
	$virtexperiment->nonfsmounts(1);
926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942
	# This is the new way of doing things.
	$virtexperiment->nfsmounts("none");
    }
    elsif (GeniXML::FromEmulabPortal($rspec) && $PROTOGENI_LOCALUSER) {
	#
	# By not setting, we get standard emulab mounts which include
	# /users. Not sure if I want to explictly set this.
	#
	# But we do not let anyone do this, at the moment only the local
	# SA can do that, which means the authority that contacted us
	# must be our SA. Not even users from our SA can specify this.
	#
	my $hrn = GeniHRN->new($ENV{"GENIURN"});
	if (defined($hrn) &&
	    $hrn->domain() eq $OURDOMAIN && $hrn->IsSA()) {
	    $virtexperiment->nfsmounts("emulabdefault");
	}
943 944
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
945
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
946 947
    # An rspec is a structure that requests specific nodes. If those
    # nodes are available, then reserve it. Otherwise the ticket
Leigh B. Stoller's avatar
Leigh B. Stoller committed
948 949
    # cannot be granted.
    #
950 951 952
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
953
    my %iface2node = ();
954
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
955
    my %nodemap  = ();
956
    my %bridgemap= ();
957
    my @nodeids  = ();
958
    my %lannodes = ();
959
    my %allnodes = ();
960 961
    # Extra nodes (like XEN vhosts).
    my %internal_nodemap  = ();
962
    # For stitching, keep track of external nodes and links.
963 964 965
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
966
    my %external_lanrefs  = ();
Leigh B Stoller's avatar
Leigh B Stoller committed
967
    my $routable_ip_count = 0;
968
    my $sync_server = ($isupdate ? $slice_experiment->sync_server() : undef);
969

970 971
    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();
972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996

    #
    # Find all the node client ids, so we can support binding VMs to other
    # nodes in the topology. We could enforce that the rspec has to put
    # those nodes first, but that would be annoying to users. And me.
    #
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
	# Let remote nodes pass through.
	next
	    if (!GeniXML::IsLocalNode($ref));

	# Skip lan nodes; they are fake.
	next
	    if (GeniXML::IsLanNode($ref));

	my $node_nickname = GeniXML::GetVirtualId($ref);

	# Might as well do a duplicate check while we are here.
	if (exists($allnodes{lc($node_nickname)})) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Duplicate node $node_nickname");
	    goto bad;
	}
	$allnodes{lc($node_nickname)} = 1;
    }
997
    
998 999 1000 1001 1002 1003 1004
    #
    # If this is a ticket update, we want to seed the namemap with
    # existing nodes. This is cause the rspec might refer to wildcards
    # that were already bound in a previous call. We also want to know
    # what nodes are currently reserved in case we have to release some.
    #
    if ($isupdate) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
	if ($slice_experiment->BackupVirtualState()) {
	    print STDERR "Could not backup virtual state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	if ($slice_experiment->RemoveVirtualState()) {
	    print STDERR "Could not remove virtual state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	$restorevirt = 1;

	if ($slice_experiment->BackupPhysicalState()) {
	    print STDERR "Could not backup physical state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
1022 1023 1024 1025 1026 1027 1028
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1029
	
1030
	foreach my $ref (GeniXML::FindNodes("n:node",
1031
					    $oldrspec)->get_nodelist()) {
1032
	    # Let remote nodes pass through.
1033
	    next
1034
		if (!GeniXML::IsLocalNode($ref));
1035

1036 1037
	    # Skip lan nodes; they are fake.
	    next
1038
		if (GeniXML::IsLanNode($ref));
1039

1040
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
1041
	    my $colocate      = GeniXML::GetColocate($ref);
1042
	    my $component_id  = GeniXML::GetNodeId($ref);
1043 1044
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
1045 1046
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
1047
				 "Bad resource $component_id in ticket");
1048 1049
		goto bad;
	    }
1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064
	    #
	    # Is the node a virtual node? Must be an update to an
	    # existing sliver/ticket, since we now return the node_id
	    # of the allocated virtual node, not the physical node.
	    #
	    if ($node->isvirtnode()) {
		my $pnode = Node->Lookup($node->phys_nodeid());
		if (!defined($pnode)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "No physical resource for $component_id");
		    goto bad;
		}
		$node = $pnode;
	    }
1065 1066 1067 1068 1069
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1070

1071
    print GeniXML::Serialize($rspec);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1072

1073
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
1074
	my $component_id  = GeniXML::GetNodeId($ref);