GeniCM.pm.in 209 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1 2
#!/usr/bin/perl -wT
#
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 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 64
use EmulabConstants;
use libEmulab;
65
use Lan;
66
use User;
67
use Experiment;
68
use NodeType;
69
use Node;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70 71
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
use XML::Simple;
73
use XML::LibXML;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
use Date::Parse;
75
use POSIX qw(strftime tmpnam ceil);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
76
use Time::Local;
77
use Compress::Zlib;
78
use File::Temp qw(tempfile);
79
use MIME::Base64;
80
use Digest::SHA1 qw(sha1_hex);
81
use POSIX ":sys_wait_h";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
82 83 84 85 86 87

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

132 133 134 135 136
# For location info.
my $default_longitude = undef;
my $default_latitude  = undef;
my $default_country   = undef;

137 138 139 140 141 142 143 144 145 146
#
# 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
147
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
148
# Respond to a Resolve request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
149 150 151 152 153 154
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
155 156
    my $type       = lc( $argref->{'type'} );
    my $hrn        = $argref->{'hrn'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
157 158 159 160

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
161 162 163 164
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
165 166 167 168 169 170 171 172 173 174 175 176
    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
177 178 179
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
180
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
181 182 183 184 185 186
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

187
    my $credential = GeniCredential::CheckCredential($cred);
188 189 190
    return $credential
	if (GeniResponse::IsResponse($credential));

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

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

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

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

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

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

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

266 267 268
    # 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.
269 270 271 272 273 274
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
275

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

    # 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) {
291
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
292 293 294 295 296 297
        $isExempted = 1;
        last;
      }
    }

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

306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
    #
    # 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
325
    #
326
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
327
    #
328
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
329
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
330 331 332 333
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

334 335 336 337 338 339
    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
340 341
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
342

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

353 354 355 356 357 358 359
    $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");

360
    my $invocation = "$PTOPGEN -x -g $version -r -f";
361 362
    if (defined($experiment)) {
	my $eid = $experiment->eid();
363
	my $pid = $experiment->pid();
364
	$invocation .= " -p $pid -e $eid";
365
    }
366 367 368 369
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
370 371 372 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
    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;
	}
    }
409
    if (open(AVAIL, "$invocation |")) {
410
	$xml = "";
411 412 413 414 415
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
    #
    # 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();
    }
437 438 439
    return $xml;
}

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

    return GetTicket($argref, 1);
}

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

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

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

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

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

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

560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577
    #
    # 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");
    }

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

584 585 586 587 588 589
    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
590 591 592 593
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
594
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
595 596 597 598
	    # Cannot get the value, say no.
	    $allow_externalusers = 0;
    }

599 600 601 602 603 604 605 606 607 608 609
    # 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);

610 611 612 613 614 615 616 617 618 619
    # 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
620
    }
621 622 623

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
624 625 626 627
				    "External users temporarily denied");
    }
    
    #
628
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
629
    # ticket is redeemed, it will expire according to the rspec request.
630 631
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
632 633
    # slice credential, or the local policy max_sliver_lifetime. See
    # CreateSliceFromCertificate() in this file.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
634
    #
Jonathon Duerig's avatar
Jonathon Duerig committed
635
    my $expires = GeniXML::GetExpires($rspec);
636
    if (defined($expires)) {
637 638
	if (GeniResponse::IsResponse($expires)) {
	    return $expires;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
639
	}
640 641
	# Note "checkonly" flag; we do not actually change the slice
	# until the ticket is redeemed. 
642
	my $tmp = SetSliceExpiration($slice, $expires, 1, 0, @{ $credentials });
643 644
	if (GeniResponse::IsResponse($tmp)) {
	    return $tmp;
645
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
646
    }
647 648 649 650 651 652 653

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
654 655 656
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
657 658 659 660 661 662
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
663 664 665
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
666
    }
667 668 669
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
670 671
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
672 673 674
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
675 676 677 678 679 680 681 682
    # 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
683

684
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
685
    # For now, there can be only a single toplevel aggregate per slice.
686
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
687
    #
688
    my $aggregate = GeniAggregate->SliceAggregate($slice);
689 690 691 692 693
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
694 695
	}
    }
696 697 698 699 700
    elsif ($v2 && $level && !defined($ticket) && !defined($aggregate)) {
	print STDERR "No aggregate for $slice in version two API\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
701

702
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
703
    # We need this now so we can form a virtual topo.
704
    #
705 706 707 708 709 710 711 712 713 714 715
    my $slice_experiment = GeniExperiment($slice, $user);
    if (GeniResponse::IsResponse($slice_experiment)) {
	$response = $slice_experiment;
	$slice_experiment = undef;
	goto bad;
    }
    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
716 717 718 719
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
720 721 722 723 724

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
725
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
726 727
    if (defined($generated_by) &&
	$generated_by eq "libvtop") {
728 729 730 731
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
732 733 734 735 736 737 738 739 740 741 742 743 744
    
    #
    # 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);
745
    $virtexperiment->multiplex_factor(10);
746

747 748 749 750 751 752 753 754 755 756
    #
    # 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()) {
757
	$virtexperiment->NewTableRow("virt_vtypes",
758 759 760 761
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
762
    }
763

764 765 766 767 768
    # Need to move this someplace else; the parser adds a bunch.
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "ns",
				  "objecttype" => "6"});
769

770 771 772
    #
    # Look for toplevel address pools
    #
773 774 775 776 777 778 779 780 781 782 783 784 785
    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") {
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
		     "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",
786 787 788 789
					 {"pool_id" => $pool->{'client_id'},
					  "count" => $pool->{'count'},
					  "restriction" => $pool->{'type'},
					  "version" => "ipv4" });
790
	    }
791 792 793
	}
    }

794 795 796 797 798 799 800 801 802 803 804 805
    #
    # 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);
	}
806 807 808
    }
    if ($PROTOGENI_NONFSMOUNTS) {
	$virtexperiment->nonfsmounts(1);
809 810
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
811
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
812 813
    # 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
814 815
    # cannot be granted.
    #
816 817 818
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
819
    my %iface2node = ();
820
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
821
    my %nodemap  = ();
822
    my %bridgemap= ();
823
    my @nodeids  = ();
824
    my %lannodes = ();
825
    # For stitching, keep track of external nodes and links.
826 827 828
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
829
    my %external_lanrefs  = ();
830

831 832 833
    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();
    
834 835 836 837 838 839 840
    #
    # 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
841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857
	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;
	}
858 859 860 861 862 863 864
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
865
	
866
	foreach my $ref (GeniXML::FindNodes("n:node",
867
					    $oldrspec)->get_nodelist()) {
868
	    # Let remote nodes pass through.
869
	    next
870
		if (!GeniXML::IsLocalNode($ref));
871

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

876
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
877
	    my $colocate      = GeniXML::GetColocate($ref);
878
	    my $component_id  = GeniXML::GetNodeId($ref);
879 880
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
881 882
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
883
				 "Bad resource $component_id in ticket");
884 885
		goto bad;
	    }
886 887 888 889 890 891 892 893 894 895 896 897 898 899 900
	    #
	    # 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;
	    }
901 902 903 904 905
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
906

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

909 910
    my %nodeexistsmap = ();

911
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
912
	my $component_id  = GeniXML::GetNodeId($ref);
913
	my $vnode_id      = GeniXML::GetVnodeId($ref);
914
	my $manager_id    = GeniXML::GetManagerId($ref);
915
	my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
916 917 918 919
	my $colocate      = GeniXML::GetColocate($ref);
	my $subnode_of    = GeniXML::GetSubnodeOf($ref);
	my $virtualization_type = GeniXML::GetVirtualizationType($ref);
	
920
	my $virtualization_subtype
Jonathon Duerig's avatar
Jonathon Duerig committed
921 922
                          = GeniXML::GetVirtualizationSubtype($ref);
	my $exclusive     = GeniXML::GetExclusive($ref);
923
	my $tarfiles      = GeniXML::GetTarball($ref);
924
	my $pctype;
925
	my ($osname, $osinfo);
926
	my $parent_osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
927
	my $node;
928 929
	my $isbridge    = 0;
	my $isfirewall  = 0;
Leigh B Stoller's avatar
Leigh B Stoller committed
930
	my $xensettings;
931
	my $fwsettings;
932
	
933
	if (exists($nodeexistsmap{lc($node_nickname)})) {
934 935 936 937 938
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate node $node_nickname");
	    goto bad;
	}
939
	$nodeexistsmap{lc($node_nickname)} = 1;
940

941 942 943 944 945
	# Always populate iface2node mapping, even if we let the node
	# pass through.
	foreach my $linkref (GeniXML::FindNodes("n:interface",
						$ref)->get_nodelist()) {
	    my $virtual_id   = GeniXML::GetInterfaceId($linkref);
946 947 948 949 950 951 952
	    if (exists($iface2node{$virtual_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Duplicate interface $virtual_id on ".
					 "node $node_nickname");
		goto bad;
	    }
953 954 955
	    $iface2node{$virtual_id} = $node_nickname;
	}

956
	# Let remote nodes pass through.
957 958 959 960
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}
961

962
	#
963 964 965 966 967
	#
	# Lan nodes are fake and do not go into the virt topo. Need
	# to remember them though, for when we do the links below.
	# They are still in the returned ticket though. 
	#
968
	if (GeniXML::IsLanNode($ref)) {
969 970 971 972
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

973 974 975 976 977 978 979 980
	#
	# Check for total hostname length > 63 characters. This
	# breaks a lot of clients. Do this until we have a plan
	# for dealing with it on the clients. Why 63 instead of 64?
	# Cause of a bug in the event library code, that is now fixed,
	# but will not make it out to all images for a while. 
	#
	my $fullhostname = $node_nickname . ".${eid}.${pid}.${OURDOMAIN}";
981
	if (0 && length($fullhostname) > 63) {
982 983 984 985
	    $response = GeniResponse->Create(GENIRESPONSE_TOOBIG, undef,
				     "Hostname > 63 characters: $fullhostname");
	    goto bad;
	}
986 987 988
	#
	# Check for disk_image request. Specified as a URN. 
	#
989
	my $diskref = GeniXML::GetDiskImage($ref);
990 991
	if (defined($diskref)) {
	    my $dname = GeniXML::GetText("name", $diskref);
992
	    my $url   = GeniXML::GetText("url", $diskref);
993

994 995 996 997 998
	    # url is deprecated; name can be anything.
	    if (defined($dname) && $dname =~ /^http/) {
		$url = $dname;
	    }

999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013
	    if (defined($url)) {
		if (! TBcheck_dbslot($url, "virt_nodes", "osname",
				 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid disk image url: $url");
		    goto bad;
		}
		#
		# Pass it right through; we load them later.
		# There is no osinfo, but see below. 
		#
		$osname = $url;
	    }
	    elsif (defined($dname)) {
1014 1015 1016 1017 1018 1019 1020
		if (! GeniHRN::IsValid($dname)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
		my ($auth,$type,$id) = GeniHRN::Parse($dname);
1021 1022
		my ($ospid,$os,undef,$vers) =
		    ($id =~ m{([^/]+)//([^/]+)(//(\d+))?});		
1023 1024 1025 1026 1027 1028
		if ($type ne "image" || !defined($ospid) || !defined($os)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
1029
		$osinfo = OSinfo->Lookup($ospid, $os, $vers);
1030
		if (!defined($osinfo)) {
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046
		    if ($use_imagetracker) {
			my $image = GeniImage::MapToLocalImage($dname, $pid);
			if (GeniResponse::IsError($image)) {
			    $response = $image;
			    goto bad;
			}
			$osname = ($image->IsLocal() ?
				   $image->versname() :
				   $image->metadata_url());
		    }
		    else {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Unknown image URN: $dname");
			goto bad;
		    }
1047
		}