All new accounts created on Gitlab now require administrator approval. If you invite any collaborators, please let Flux staff know so they can approve the accounts.

GeniCM.pm.in 115 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1 2
#!/usr/bin/perl -wT
#
3
# GENIPUBLIC-COPYRIGHT
4
# Copyright (c) 2008-2010 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
# All rights reserved.
#
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);

@ISA    = "Exporter";
@EXPORT = qw ( );

# Must come after package declaration!
use lib '@prefix@/lib';
use GeniDB;
use Genixmlrpc;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
24 25
use GeniResponse;
use GeniTicket;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
26
use GeniCredential;
27
use GeniCertificate;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
28
use GeniSlice;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
use GeniAggregate;
30
use GeniAuthority;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
31
use GeniSliver;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
32
use GeniUser;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
33
use GeniRegistry;
34
use GeniUtil;
35
use GeniHRN;
36
use GeniXML;
37
use GeniUsage;
38
use libtestbed qw(SENDMAIL);
39
use emutil;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
40
# Hate to import all this crap; need a utility library.
41 42
use libdb qw(TBGetSiteVar EXPTSTATE_SWAPPED EXPTSTATE_ACTIVE TBOPSPID
	     TBDB_NODESTATE_TBFAILED);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
43
use User;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
44
use Node;
45
use Lan;
46
use OSinfo;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
use Image;
48
use Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
49 50
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
51
use XML::Simple;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52
use Date::Parse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
53
use POSIX qw(strftime tmpnam);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
54
use Time::Local;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
55
use Experiment;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
56
use VirtExperiment;
57
use Firewall;
58
use Compress::Zlib;
59
use File::Temp qw(tempfile);
60
use MIME::Base64;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
61 62 63 64 65 66 67 68

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
69
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70
my $CREATEEXPT     = "$TB/bin/batchexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
71
my $ENDEXPT        = "$TB/bin/endexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
my $NALLOC	   = "$TB/bin/nalloc";
73
my $NFREE	   = "$TB/bin/nfree";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
my $AVAIL	   = "$TB/sbin/avail";
75
my $PTOPGEN	   = "$TB/libexec/ptopgen";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
76 77
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
78 79
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
80
my $EXPORTS_SETUP  = "$TB/sbin/exports_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
81 82
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
83
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
84 85 86 87
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
my $SNMPIT         = "$TB/bin/snmpit";
my $PRERENDER      = "$TB/libexec/vis/prerender";
88
my $XMLLINT	   = "/usr/local/bin/xmllint";
89
my $ADDAUTHORITY   = "$TB/sbin/protogeni/addauthority";
90
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
91
my $API_VERSION    = 1;
92 93 94 95 96 97 98 99 100 101 102

#
# 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
103
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
104
# Respond to a Resolve request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
105 106 107 108 109 110
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
111 112
    my $type       = lc( $argref->{'type'} );
    my $hrn        = $argref->{'hrn'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
113 114 115 116

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
117 118 119 120
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
121 122 123 124 125 126 127 128 129 130 131 132
    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
133 134 135
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
136
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
137 138 139 140 141 142
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

143 144 145 146
    my $credential = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

147
    if ($type eq "node") {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
148 149 150
	my $node;
	
	if (defined($uuid)) {
151
	    $node= GeniUtil::LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
152 153
	}
	else {
154
	    $node= GeniUtil::LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
155
	}
156
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
157 158 159
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
160

161
	my $rspec = GetAdvertisement(0, $node->node_id(), "0.1");
162 163 164 165
	if (! defined($rspec)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not start avail");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
166 167
	
	# Return a blob.
168
	my $blob = { "hrn"          => "${PGENIDOMAIN}." . $node->node_id(),
Leigh B. Stoller's avatar
Leigh B. Stoller committed
169
		     "uuid"         => $node->uuid(),
170
		     "role"	    => $node->role(),
171 172
		     "hostname"     =>
			 GeniUtil::FindHostname($node->node_id()),
173 174
		     "physctrl"     => 
			 Interface->LookupControl( $node->phys_nodeid() )->IP(),
175 176
		     "urn"          => GeniHRN::Generate( $OURDOMAIN,
							  "node",
177 178
							  $node->node_id() ),
		     "rspec"        => $rspec
Leigh B. Stoller's avatar
Leigh B. Stoller committed
179 180 181 182 183 184 185
		   };

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
186 187 188 189 190 191
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
192
    my $credstr   = $argref->{'credential'};
193
    my $available = $argref->{'available'} || 0;
194 195 196 197 198
    my $compress  = $argref->{'compress'} || 0;

    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
199

200
    return DiscoverResourcesAux($available, $compress, [$credential]);
201 202
}
# Helper function for V2.
203
sub DiscoverResourcesAux($$$)
204
{
205
    my ($available, $compress, $credentials) = @_;
206
    my $user_urn  = $ENV{'GENIRN'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
207

208 209 210
    # 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.
211 212 213 214 215 216
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
217

Leigh B. Stoller's avatar
Leigh B. Stoller committed
218 219 220 221 222
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!TBGetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
223 224
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
225
    }
226 227 228 229 230 231 232

    # 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) {
233
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
234 235 236 237 238 239
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
240
	my $user = GeniUser->Lookup($user_urn, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
241 242 243 244 245 246 247
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
248
    #
249
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
250
    #
251
    my $xml = GetAdvertisement($available, undef, "0.2");
252
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
253 254 255 256
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

257 258 259 260 261 262
    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
263 264
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
265

266 267 268
#
# Use ptopgen in xml mode to spit back an xml file. 
#
269
sub GetAdvertisement($$$)
270
{
271
    my ($available, $pc, $version) = @_;
272 273
    my $xml = undef;

274
    my $invocation = "$PTOPGEN -x -g $version -r -p GeniSlices";
275 276 277 278 279
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
    if (open(AVAIL, "$invocation |")) {
280
	$xml = "";
281 282 283 284 285 286 287 288
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
    return $xml;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
289
#
290
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
291
#
292
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
293 294
{
    my ($argref) = @_;
295 296 297 298 299 300 301 302 303 304

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
305
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
306
    my $impotent   = $argref->{'impotent'};
307 308
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
309 310 311 312 313 314 315
    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
316

317
    if (! defined($credstr)) {
318
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
319
    }
320
    if (!defined($rspecstr)) {
321 322
	return GeniResponse->MalformedArgsResponse();
    }
323 324 325 326
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
327 328 329 330
    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

331
    if ($isupdate) {
332 333 334
	$ticket = CheckTicket($tickstr);
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
335
    }
336
    return GetTicketAux($credential,
337
			$rspecstr, $isupdate, $impotent, 0, 1, $ticket);
338
}
339

340
sub GetTicketAux($$$$$$$)
341
{
342 343
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level,
	$ticket) = @_;
344
    
345 346 347 348 349 350
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
351
    
352 353
    my $slice_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
354
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
355
    #
356
    # Create user from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
357
    #
358 359
    my $user = CreateUserFromCertificate($credential->owner_cert());
    if (!defined($user)) {
360
	if ($isupdate) {
361
	    print STDERR "Could not locate $user_urn for UpdateTicket\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
362
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
363
					"No user found for UpdateTicket");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
364
	}
365
	return GeniResponse->Create(GENIRESPONSE_ERROR);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
366 367
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
368
    #
369
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
370
    #
371 372
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
373
	if ($isupdate) {
374
	    print STDERR "Could not locate slice $slice_urn for Update\n";
375
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
376 377 378 379 380 381 382
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
	if (!defined($slice)) {
	    print STDERR "Could not create $slice_urn\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create slice");
383
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
384
    }
385
    
386
    return GetTicketAuxAux($slice, $user, $rspecstr,
387 388
			   $isupdate, $impotent, $v2, $level, $ticket,
			   [$credential]);
389
}
390
sub GetTicketAuxAux($$$$$$$$$)
391
{
392 393
    my ($slice, $user, $rspecstr, 
        $isupdate, $impotent, $v2, $level, $ticket, $credentials) = @_;
394 395 396 397 398 399 400 401 402
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state

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

407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
    #
    # 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");
    }

425 426
    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
427
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
428
				    "Error Parsing rspec XML");
429
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
430

Leigh B. Stoller's avatar
Leigh B. Stoller committed
431 432 433 434 435
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!TBGetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
436 437 438 439 440 441 442 443 444 445 446 447 448 449
	    # Cannot get the value, say no.
	    $allow_externalusers = 0;
    }

    # 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
450
    }
451 452 453

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
454 455 456 457
				    "External users temporarily denied");
    }
    
    #
458
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
459
    # ticket is redeemed, it will expire according to the rspec request.
460 461 462
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
    # slice credential.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
463
    #
464 465
    my $expires = GeniXML::GetText("valid_until", $rspec);
    if (defined($expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
466 467 468 469 470 471 472 473 474 475 476 477
	if (! ($expires =~ /^[-\w:.\/]+/)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Illegal valid_until in rspec");
	}
	# Convert to a localtime.
	my $when = timegm(strptime($expires));
	if (!defined($when)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Could not parse valid_until");
	}
	
	#
478
	# Do we need a policy limit?
479 480 481 482
  # A sitevar controls the sliver lifetime.
  #
  my $max_sliver_lifetime = 0;
  if (!TBGetSiteVar('protogeni/max_sliver_lifetime', \$max_sliver_lifetime)){
483 484
	    # Cannot get the value, default it to 90 days.
	    $max_sliver_lifetime = 90;
485 486 487 488 489
  }

  # Check if the user has a credential that lets him obtain slivers
  # with extended sliver lifetime. If so allow him to get sliver.
  foreach my $credential (@$credentials) {
490 491 492 493 494 495
      my $nodes = GeniXML::FindNodesNS("//n:max_sliver_lifetime",
          $credential->extensions(), $GeniUtil::EXTENSIONS_NS);
      if ($nodes->size > 0) {
          $max_sliver_lifetime = int($nodes->pop()->string_value);
          last;
      }
496
  }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
497
	my $diff = $when - time();
498
	if ($diff < (60 * 5) || $diff > (3600 * 24 * $max_sliver_lifetime)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
499 500 501
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"valid_until out of range");
	}
502 503 504 505 506 507

	#
	# Must be before the slice expires.
	#
	my $slice_expires = $slice->expires();
	if (defined($slice_expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
508
	    $slice_expires = str2time($slice_expires);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
509
	    if ($when > $slice_expires) {
510 511 512 513
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "valid_until is past slice expiration");
	    }
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
514
    }
515 516 517 518 519 520 521

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
522 523 524
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
525 526 527 528 529 530
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
531 532 533
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
534
    }
535 536 537
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
538 539
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
540 541 542
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
543 544 545 546 547 548 549 550
    # 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
551

552
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
553
    # For now, there can be only a single toplevel aggregate per slice.
554
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
555
    #
556
    my $aggregate = GeniAggregate->SliceAggregate($slice);
557 558 559 560 561
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
562 563
	}
    }
564 565 566 567 568
    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;
    }
569 570 571 572

    #
    # Firewall hack; just a flag in the rspec for now.
    #
573 574 575
    my $needsfirewall = GeniXML::GetText("needsfirewall", $rspec);
    if (defined($needsfirewall)) {
	if ($slice->SetFirewallFlag($needsfirewall) != 0) {
576 577
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
578 579
	}
    }
580 581

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
582
    # We need this now so we can form a virtual topo.
583
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
584 585 586 587 588 589 590 591
    my $slice_experiment = GeniExperiment($slice);
    if (!defined($slice_experiment)) {
	print STDERR "Could not create new Geni slice experiment!\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
592 593 594 595 596

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
597
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
598 599
    if (defined($generated_by) &&
	$generated_by eq "libvtop") {
600 601 602 603
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
604 605 606 607 608 609 610 611 612 613 614 615 616
    
    #
    # 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);
617
    $virtexperiment->multiplex_factor(3);
618 619

    # This is where nodes are parked until a ticket is redeemed.
620
    # This experiment no longer has to exist.
621
    my $reserved_holding = Experiment->Lookup("GeniSlices", "reservations");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
622

Leigh B. Stoller's avatar
Leigh B. Stoller committed
623
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
624 625
    # 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
626 627
    # cannot be granted.
    #
628 629 630
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
631
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
632
    my %nodemap  = ();
633
    my @nodeids  = ();
634
    my %lannodes = ();
635 636 637 638 639 640 641 642

    #
    # 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
643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660
	$slice_experiment->ClearBackupState();
	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;
	}
661 662 663 664 665 666 667
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
668
	
669
	foreach my $ref (GeniXML::FindNodes("n:node",
670
					    $oldrspec)->get_nodelist()) {
671
	    # Let remote nodes pass through.
672
	    next
673
		if (!GeniXML::IsLocalNode($ref));
674

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

679 680 681
	    my $node_nickname = GeniXML::GetVirtualId($ref);
	    my $colocate      = GeniXML::GetText("colocate", $ref) ||
		                GeniXML::GetText("phys_nickname", $ref);
682 683
	    my $component_id  = GeniXML::GetNodeId($ref);
	    my $node = GeniUtil::LookupNode($component_id);
684 685
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
686
				 "Bad resource $component_id in ticket");
687 688 689
		goto bad;
	    }

690 691 692 693 694 695
	    #
	    # Grab the reservation. For backwards compatibility, we want
	    # to find nodes in the reservations holding area, and move them
	    # into the slice experiment. The holding area is no longer going
	    # to be used, at least not until we have a reservations system.
	    #
696
	    my $reservation = $node->Reservation();
697
	    if (defined($reservation) &&
698
		defined($reserved_holding) &&
699 700 701 702 703 704
		$reservation->SameExperiment($reserved_holding)) {
		if ($node->MoveReservation($slice_experiment)) {
		    print STDERR "Could not move $node to $slice_experiment\n";
		    goto bad;
		}
		$node->Refresh();
705 706 707 708 709 710
	    }
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
711

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

714
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
715 716
	my $component_id  = GeniXML::GetNodeId($ref);
	my $manager_id    = GeniXML::GetManagerId($ref);
717 718 719 720
	my $node_nickname = GeniXML::GetVirtualId($ref);
	my $colocate      = GeniXML::GetText("colocate", $ref) ||
	                    GeniXML::GetText("phys_nickname", $ref);
	my $subnode_of    = GeniXML::GetText("subnode_of", $ref);
721
	my $virtualization_type
722
                          = GeniXML::GetText("virtualization_type", $ref);
723
	my $virtualization_subtype
724
                          = GeniXML::GetText("virtualization_subtype",
725
					     $ref);
726
	my $exclusive     = GeniXML::GetText("exclusive", $ref);
727
	my $pctype;
728
	my $osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
729 730
	my $node;

731
	# Let remote nodes pass through.
732
	next
733
	    if (! GeniXML::IsLocalNode($ref));
734

735 736 737 738 739
	#
	# 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. 
	#
740
	if (GeniXML::IsLanNode($ref)) {
741 742 743 744
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767
	#
	# Check for disk_image request. Specified as a URN. 
	#
	my $diskref = GeniXML::FindFirst("n:disk_image", $ref);
	if (defined($diskref)) {
	    my $dname = GeniXML::GetText("name", $diskref);

	    if (defined($dname)) {
		if (! GeniHRN::IsValid($dname)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
		my ($auth,$type,$id) = GeniHRN::Parse($dname);
		my ($ospid,$os) = ($id =~ m{(.*)//(.*)});
		if ($type ne "image" || !defined($ospid) || !defined($os)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
		#
768 769
		# For now, the project has to be emulab-ops or the
		# the current project.
770
		#
771 772
		if (! ($ospid eq TBOPSPID() ||
		       $ospid eq $slice_experiment->pid())) {
773 774 775 776 777
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Illegal project name in URN: $dname");
		    goto bad;
		}
778
		my $osinfo = OSinfo->Lookup($ospid, $os);
779 780 781
		if (!defined($osinfo)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
782
					     "Unknown image URN: $dname");
783 784 785 786 787 788 789 790 791
		    goto bad;
		}
		#
		# This is only going to be used in raw mode. 
		#
		$osname = $os;
	    }
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
792 793 794
	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
795 796
		    $pctype = "pcvm";
		    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
797 798 799 800 801 802
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
			$osname = "OPENVZ-STD";
		    }
803 804 805 806
		    elsif ($virtualization_subtype eq "emulab-spp") {
			$osname = "SPPVM-FAKE";
			$pctype = "sppvm";
			# Lets force to shared node.
807 808 809 810
			if (! GeniXML::SetText("exclusive", $ref, 0)) {
			    $response
				= GeniResponse->Create(GENIRESPONSE_BADARGS,
						       undef,
811 812
				       "Malformed rspec: ".
				       "Cannot set exclusive tag to false");
813 814 815
			    goto bad;
			}
			$exclusive = 0;
816 817
			# Kludge for libvtop.
			$virtexperiment->multiplex_factor(1);
818
			$virtexperiment->encap_style("vlan");
819
		    }
820 821 822 823
		    elsif ($virtualization_subtype eq "raw") {
			$pctype = undef;
			goto raw;
		    }
824 825 826 827 828 829 830 831
		    else {
			$response
			    = GeniResponse->Create(GENIRESPONSE_BADARGS,
						   undef,
				       "Malformed rspec: ".
				       "Unknown virtualization_subtype");
			goto bad;
		    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
832 833 834 835 836 837 838 839
		}
		else {
		    goto raw;
		}
	    }
	    else {
	      raw:
		# Lets force to exclusive real node.
840 841 842
		if (! GeniXML::SetText("exclusive", $ref, 1)) {
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
843
			"Malformed rspec: Cannot set exclusive tag to true");
844 845 846 847 848 849
		    goto bad;
		}
		$exclusive = 1;
		if (! GeniXML::SetText("virtualization_type", $ref, "raw")) {
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
850
			"Malformed rspec: Cannot set virtualization_type to raw");
851 852
		    goto bad;
		}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
853 854 855 856
	    }
	}
	else {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
857
				     "Must provide a virtualization_type");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
858 859 860
	    goto bad;

	}
861 862 863 864 865 866
	if (!defined($node_nickname)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtual_id for nodes");
	    goto bad;
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
867
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
868
	# Allow wildcarding.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
869
	#
870
	if (!defined($component_id) || $component_id eq "*") {
871 872 873 874 875
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
876
	    }
877 878 879 880 881 882 883 884
	    # If the node still isn't bound and doesn't have a pctype,
	    # use the user-specified one.
	    if (! defined($node) && ! defined($pctype)) {
		my $usertype = GeniXML::FindFirst("n:node_type", $ref);
		if (defined($usertype)) {
		    $pctype = GeniXML::GetText("type_name", $usertype);
		}
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
885 886
	}
	else {
887
	    $node = GeniUtil::LookupNode($component_id);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
888 889 890 891

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
892
					 "Bad resource $component_id");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
893 894
		goto bad;
	    }
895 896
	    $pctype = $node->type()
		if (!defined($pctype));
897 898
	}
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
899
	# If no osname by this point, try for the default.
900 901
	#
	if (defined($node) && !defined($osname)) {
902 903 904 905 906
	    if (defined($node->default_osid())) {	    
		my $osinfo = OSinfo->Lookup($node->default_osid());
		$osname = $osinfo->osname()
		    if (defined($osinfo));
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
907
	}
908 909 910
	# The slot does not like to be NULL.
	$osname = ""
	    if (!defined($osname));
911
	
912 913 914
	# Need some kind of default.
	$pctype = "pc"
	    if (!defined($pctype));
915
	
916 917 918 919 920
	my $nodeblob = {"vname"   => $node_nickname,
			"type"    => $pctype,
			"osname"  => $osname,
			"ips"     => '', # deprecated
			"cmd_line"=> '', # bogus
Leigh B. Stoller's avatar
Leigh B. Stoller committed
921 922
			"fixed"   => (defined($subnode_of) ? $subnode_of :
				      defined($node) ? $node->node_id() : ""),
923
			};
924 925

	# Tarball and startup command.
926
	my $startupcmd = GeniXML::GetText("startup_command", $ref);
927
	if (defined($startupcmd)) {
928 929 930 931 932 933 934 935 936
	    if (! TBcheck_dbslot($startupcmd, "virt_nodes", "startupcmd",
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Invalid startup command");
		goto bad;
	    }
	    $nodeblob->{'startupcmd'} = $startupcmd;
	}
937
	my $tarfiles = GeniXML::GetText("tarfiles", $ref);
938
	if (defined($tarfiles)) {
939
	    if (! TBcheck_dbslot($tarfiles, "virt_nodes", "tarfiles",
940 941 942 943 944 945
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Invalid tarfiles");
		goto bad;
	    }
946
	    $nodeblob->{'tarfiles'} = $tarfiles;
947 948 949 950 951 952 953 954
	}

	my $virtnode = $virtexperiment->NewTableRow("virt_nodes", $nodeblob);
	if (!defined($virtnode)) {
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					     "Error creating virtnode");
	    goto bad;
	}
955

Leigh B. Stoller's avatar
Leigh B. Stoller committed
956 957 958 959 960 961 962 963 964 965
	$virtexperiment->NewTableRow("virt_node_desires",
				     {"vname"    => $node_nickname,
				      "desire"   => "pcshared",
				      "weight"   => 0.95})
	    if (!defined($exclusive) || !$exclusive);

	# Store reference so we can munge it below. 
	$nodemap{$node_nickname} = {"rspec"    => $ref,
				    "virtnode" => $virtnode};
	
966 967 968 969
	#
	# Look for interface forward declarations that will be used later
	# in the link specifications. 
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
970
	next
971
	    if (!defined(GeniXML::FindFirst("n:interface", $ref)));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
972
	
973
	foreach my $linkref (GeniXML::FindNodes("n:interface",
974
						$ref)->get_nodelist()) {
975
	    my $virtual_id   = GeniXML::GetText("virtual_id", $linkref);
976 977 978 979 980 981 982 983 984 985

	    if (!defined($virtual_id)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			     "Must provide a virtual_id for interfaces");
		goto bad;
	    }
	    
	    $ifacemap{$node_nickname} = {}
	        if (!exists($ifacemap{$node_nickname}));

Leigh B. Stoller's avatar
Leigh B. Stoller committed
986 987 988
	    # port counter.
	    my $vport = scalar(keys(%{ $ifacemap{$node_nickname} }));

989
	    # Store reference so we can munge it below. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
990 991
	    $ifacemap{$node_nickname}->{$virtual_id} = {"rspec" => $linkref,
							"vport" => $vport};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
992

Leigh B. Stoller's avatar
Leigh B. Stoller committed
993
	    # This is used after the mapper runs since it uses vname:vport.
994
	    $vportmap{"$node_nickname:$vport"} = {"rspec" => $linkref};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
995
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
996 997
    }

998
    goto skiplinks
999
	if (!defined(GeniXML::FindFirst("n:link", $rspec)));
1000
    
1001
    #
1002
    # Now deal with links for wildcarded nodes. 
1003
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1004 1005
    my $linknum = 1;
    
1006
    foreach my $linkref (GeniXML::FindNodes("n:link",
1007
					    $rspec)->get_nodelist()) {
1008
	my $lanname    = GeniXML::GetVirtualId($linkref);
1009 1010
	my $link_type  = GeniXML::GetText("link_type", $linkref);
	my $istunnel   = (defined($link_type) && $link_type eq "tunnel");
1011 1012
	my @interfaces = GeniXML::FindNodes("n:linkendpoints | ".
					    "n:interface_ref",
1013
					    $linkref)->get_nodelist();
1014
	my %managers   = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1015
	my $ifacenum   = 1;
1016
	my $trivial_ok = 0;
1017

1018
	if (!defined($lanname)) {
1019 1020 1021 1022
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtual_id for links");
	    goto bad;
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1023

1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040
	#
	# Look for managers list; optional for now. If not specified then
	# we assume the link is for thie CM.
	#
	if (GeniXML::FindNodes("n:component_manager", $linkref)) {
	    %managers = map { GeniXML::GetText("id", $_) => $_ } 
	                      GeniXML::FindNodes("n:component_manager",
						 $linkref)->get_nodelist();