GeniCM.pm.in 82.5 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-2009 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 libtestbed qw(SENDMAIL);
37
use emutil;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
38
# Hate to import all this crap; need a utility library.
39
use libdb qw(TBGetSiteVar);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
40
use User;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
41
use Node;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42
use libadminctrl;
43
use Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
44
45
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
46
use XML::Simple;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
48
49
use Date::Parse;
use POSIX qw(strftime);
use Time::Local;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
50
use Experiment;
51
use Firewall;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52
53
54
55
56
57
58
59

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
60
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
61
my $CREATEEXPT     = "$TB/bin/batchexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
62
my $ENDEXPT        = "$TB/bin/endexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
63
my $NALLOC	   = "$TB/bin/nalloc";
64
my $NFREE	   = "$TB/bin/nfree";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
65
my $AVAIL	   = "$TB/sbin/avail";
66
my $PTOPGEN	   = "$TB/libexec/ptopgen";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
67
68
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
69
70
71
72
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
73
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
75

#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
76
# Respond to a Resolve request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
77
78
79
80
81
82
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
83
84
    my $type       = lc( $argref->{'type'} );
    my $hrn        = $argref->{'hrn'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
85
86
87
88

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
89
90
91
92
93
94
95
96
97
98
99
100
    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
101
102
103
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
104
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    
    #
    # Make sure the credential was issued to the caller, but no special
    # permission required to resolve component resources.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
125
    if ($type eq "node") {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
126
127
128
129
130
131
132
133
134
135
	my $node;
	
	if (defined($uuid)) {
	    $node= Node->Lookup($uuid);
	}
	else {
	    #
	    # We only want the last token for node lookup.
	    #
	    if ($hrn =~ /\./) {
136
		($hrn) = ($hrn =~ /\.([-\w]*)$/);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
137
138
139
140
141
142
143
144
145
	    }
	    $node= Node->Lookup($hrn);
	}
	if (!defined($node)) {
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
	
	# Return a blob.
146
	my $blob = { "hrn"          => "${PGENIDOMAIN}." . $node->node_id(),
Leigh B. Stoller's avatar
Leigh B. Stoller committed
147
		     "uuid"         => $node->uuid(),
148
		     "role"	    => $node->role(),
149
		     "hostname"     => $node->node_id() . ".${OURDOMAIN}",
150
151
		     "physctrl"     => 
			 Interface->LookupControl( $node->phys_nodeid() )->IP(),
152
153
154
		     "urn"          => GeniHRN::Generate( $OURDOMAIN,
							  "node",
							  $node->node_id() )
Leigh B. Stoller's avatar
Leigh B. Stoller committed
155
156
157
158
159
160
161
162
163
164
165
166
167
		   };

	#
	# Get the list of interfaces for the node.
	#
	my @interfaces;
	if ($node->AllInterfaces(\@interfaces) != 0) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not get interfaces for $uuid");
	}

	my @iblobs = ();
	foreach my $interface (@interfaces) {
168
169
170
	    next
		if (!defined($interface->switch_id()));
		
171
172
173
	    my $urn = GeniHRN::Generate( $OURDOMAIN, "interface",
					 $node->node_id() . ":" .
					 $interface->iface() );
Leigh B. Stoller's avatar
Leigh B. Stoller committed
174
175
176
177
178
179
	    my $iblob = { "uuid"	=> $interface->uuid(),
			  "iface"	=> $interface->iface(),
			  "type"	=> $interface->type(),
			  "card"	=> $interface->card(),
			  "port"	=> $interface->port(),
			  "role"	=> $interface->role(),
180
181
			  "IP"		=> $interface->IP() || "",
			  "mask"	=> $interface->mask() || "",
Leigh B. Stoller's avatar
Leigh B. Stoller committed
182
			  "MAC"		=> $interface->mac(),
183
184
185
186
187
			  "switch_id"   => "${OURDOMAIN}." . 
			      $interface->switch_id(),
			  "switch_card"	=> $interface->switch_card(),
			  "switch_port"	=> $interface->switch_port(),
			  "wire_type"	=> $interface->wire_type(),
188
			  "urn"         => $urn
Leigh B. Stoller's avatar
Leigh B. Stoller committed
189
190
191
192
193
194
195
196
197
198
199
200
		      };

	    push(@iblobs, $iblob);
	}
	$blob->{'interfaces'} = \@iblobs
	    if (@iblobs);
	
	return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
    }
    return GeniResponse->Create(GENIRESPONSE_UNSUPPORTED);
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
    my $credential = $argref->{'credential'};
    my $user_uuid  = $ENV{'GENIUSER'};

    $credential = GeniCredential->CreateFromSigned($credential);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    # The credential owner/slice has to match what was provided.
216
    if ($user_uuid ne $credential->owner_uuid()) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
217
218
219
220
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!TBGetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
	# Cannot get the value, say no.
	$allow_externalusers = 0;
    }
    if (!$allow_externalusers) {
	my $user = GeniUser->Lookup($user_uuid, 1);
	# 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
238
    #
239
    # Use ptopgen in xml mode to spit back an xml file. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
240
    #
241
    if (! open(AVAIL, "$PTOPGEN -x -g -r -p GeniSlices |")) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
242
243
244
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }
245
    my $xml = "";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
246
    while (<AVAIL>) {
247
	$xml .= $_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
248
249
250
251
252
    }
    close(AVAIL);

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
254
#
255
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
256
#
257
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
258
259
{
    my ($argref) = @_;
260
261
262
263
264
265
266
267
268
269

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
270
    my $rspec      = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
271
    my $impotent   = $argref->{'impotent'};
272
    my $cred       = $argref->{'credential'};
273
274
    my $tick       = $argref->{'ticket'};
    my $uuid       = $argref->{'uuid'};
275
    my $vtopo      = $argref->{'virtual_topology'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
276
    my $owner_uuid = $ENV{'GENIUSER'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
277
    my $response   = undef;
278
279
280
281
282
283
284
285
    my $didfwsetup = 0;
    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
286

287
288
    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
289
    }
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
    if (defined($uuid)) {
	if (!($uuid =~ /^[-\w]*$/)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Improper ticket uuid: $uuid");
	}
	$ticket = GeniTicket->Lookup($uuid);
	if (!defined($ticket)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"No such ticket here: $uuid");
	}
    }
    elsif (defined($rspec)) {
	if (! ($rspec =~ /^[\040-\176\012\015\011]+$/)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Improper rspec");
	}
	$rspec = XMLin($rspec, KeyAttr => [],
		       ForceArray => ["node", "link", "interface",
				      "interface_ref", "linkendpoints"]);
    }
    else {
	return GeniResponse->MalformedArgsResponse();
    }
    if ($isupdate) {
	$ticket = GeniTicket->CreateFromSignedTicket($tick);
	if (!defined($ticket)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create GeniTicket object");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
319
    }
320
    my $credential = GeniCredential->CreateFromSigned($cred);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
321
322
323
324
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
325
    my $slice_uuid = $credential->target_uuid();
326
    my $user_uuid  = $credential->owner_uuid();
327
        
328
329
330
    #
    # Make sure the credential was issued to the caller.
    #
331
    if ($user_uuid ne $ENV{'GENIUUID'}) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
332
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
333
				    "This is not your credential!");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
334
    }
335
336
337
338
339
340
341
    
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
342

343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
    #
    # Deal with a duplicate ticket request, after verifying credential.
    #
    if (defined($uuid)) {
	#
	# Return the original ticket string, rather then creating and signing
	# a new version. Only the original requestor can get the ticket, which
	# can then be delegated if necessary. 
	#
	if ($user_uuid ne $ticket->owner_uuid()) {
	    return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
					"Not your ticket!");
	}
	return GeniResponse->Create(GENIRESPONSE_SUCCESS, $ticket->asString());
    }
    
    #
    # We need this below to sign the ticket.
    #
    my $authority = GeniCertificate->LoadFromFile($EMULAB_PEMFILE);
    if (!defined($authority)) {
	print STDERR " Could not get uuid from $EMULAB_PEMFILE\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
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_uuid);
    if (!defined($slice)) {
373
374
375
376
377
	if ($isupdate) {
	    print STDERR "Could not locate slice $slice_uuid for Update\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice found for UpdateTicket");
	}
378
	$slice = CreateSliceFromCertificate($credential);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
379
	if (!defined($slice)) {
380
	    print STDERR "Could not create $slice_uuid\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
381
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
382
					"Could not create slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
383
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
384
385
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
386
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
387
388
    # Ditto the user.
    #
389
    my $user = GeniUser->Lookup($user_uuid, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
390
    if (!defined($user)) {
391
392
393
394
395
	if ($isupdate) {
	    print STDERR "Could not locate $user_uuid for UpdateTicket\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No user found for UpdateTicket");
	}
396
	$user = CreateUserFromCertificate($credential->owner_cert());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
397
	if (!defined($user)) {
398
	    print STDERR "No user $user_uuid in the ClearingHouse\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
399
400
401
402
403
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Could not get user info from ClearingHouse");
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
404
405
406
407
408
409
410
411
412
413
414
415
416
417
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!TBGetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
	# Cannot get the value, say no.
	$allow_externalusers = 0;
    }
    if (!$allow_externalusers && !$user->IsLocal()) {
	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				    "External users temporarily denied");
    }
    
    #
418
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
    # ticket is redeemed, it will expire according to the rspec request.
    #
    if (exists($rspec->{'valid_until'})) {
	my $expires = $rspec->{'valid_until'};

	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");
	}
	
	#
	# No more then 24 hours out ... Needs to be a sitevar?
	#
	my $diff = $when - time();
	if ($diff < (60 * 15) || $diff > (3600 * 24)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"valid_until out of range");
	}
    }
    else {
	# Give it a reasonable default for later when the ticket is redeemed.
	$rspec->{'valid_until'} =
	    POSIX::strftime("20%y-%m-%dT%H:%M:%S", gmtime(time() + (3600*1)));
    }
449
450
451
452
453
454
455

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
456
457
458
459
460
461
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
462
463
464
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
465
    }
466
467
468
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
469
470
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
471
472
473
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
474

475
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
476
    # For now, there can be only a single toplevel aggregate per slice.
477
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
478
    #
479
480
481
482
483
484
    if (!$isupdate) {
	my $aggregate = GeniAggregate->SliceAggregate($slice);
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
485
486
487
488
489
490
491
492
	}
    }

    #
    # Firewall hack; just a flag in the rspec for now.
    #
    if (exists($rspec->{'needsfirewall'}) && $rspec->{'needsfirewall'}) {
	if ($slice->SetFirewallFlag($rspec->{'needsfirewall'}) != 0) {
493
494
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
495
496
	}
    }
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511

    #
    # Until a ticket is redeemed, there is no experiment.
    #
    my $slice_experiment = $slice->GetExperiment();

    # This is where nodes are parked until a ticket is redeemed.
    my $reserved_holding = Experiment->Lookup("GeniSlices", "reservations");
    if (!defined($reserved_holding)) {
	#
	# This experiment has to exist!
	#
	print STDERR "Could not find Geni reservations experiment!\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
512
513
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
514
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
515
516
    # 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
517
518
    # cannot be granted.
    #
519
520
521
522
523
    my %namemap  = ();
    my %tofree   = ();
    my %colomap  = ();
    my %ifacemap = ();
    my @nodeids  = ();
524
    my @dealloc;
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561

    #
    # 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) {
	foreach my $ref (@{$ticket->rspec()->{'node'}}) {
	    my $resource_uuid = $ref->{'component_uuid'} || $ref->{'uuid'};
	    my $manager_uuid  = $ref->{'component_manager_uuid'};
	    my $node_nickname = $ref->{'virtual_id'} || $ref->{'nickname'};
	    my $colocate      = $ref->{'colocate'} || $ref->{'phys_nickname'};

	    # Let remote nodes pass through.
	    next
		if (defined($manager_uuid) && $manager_uuid ne $ENV{'MYUUID'});

	    my $node = Node->Lookup($resource_uuid);
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad resource $resource_uuid in ticket");
		goto bad;
	    }

	    # Grab the reservation. We will want to release unused nodes,
	    # but only if not already assigned to the slice.
	    my $reservation = $node->Reservation();
	    if (defined($reservation)) {
		$tofree{$resource_uuid} = $node
		    if ($reservation->SameExperiment($reserved_holding));
	    }
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
562

563
    foreach my $ref (@{$rspec->{'node'}}) {
564
565
566
567
	my $resource_uuid = $ref->{'component_uuid'} || $ref->{'uuid'};
	my $manager_uuid  = $ref->{'component_manager_uuid'};
	my $node_nickname = $ref->{'virtual_id'} || $ref->{'nickname'};
	my $colocate      = $ref->{'colocate'} || $ref->{'phys_nickname'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
568
	my $virtualization_type = $ref->{'virtualization_type'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
569
570
	my $node;

571
572
573
574
575
576
577
578
579
580
	# Let remote nodes pass through.
	next
	    if (defined($manager_uuid) && $manager_uuid ne $ENV{'MYUUID'});

	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
581
582
583
	#
	# Mostly for debugging right now, allow a wildcard.
	#
584
585
586
587
588
589
	if (!defined($resource_uuid) || $resource_uuid eq "*") {
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
590
591
592
593
	    }
	    else {
		$node = FindFreeNode($virtualization_type, @nodeids);
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
594
595
596
597
598
599
600
601
	    
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_UNAVAILABLE,
						 undef,
						 "No free nodes for wildcard");
		goto bad;
	    }
	    $resource_uuid = $node->uuid();
602
603
	    $ref->{'component_uuid'} = $node->uuid();
	    $ref->{'component_manager_uuid'} = $ENV{'MYUUID'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
604
605
606
607
608
609
610
611
612
613
	}
	else {
	    $node = Node->Lookup($resource_uuid);

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad resource $resource_uuid");
		goto bad;
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
614
	}
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635

	#
	# Look for interface forward declarations that will be used later
	# in the link specifications. 
	#
	foreach my $linkref (@{$ref->{'interface'}}) {
	    my $component_id = $linkref->{"component_id"};
	    my $virtual_id   = $linkref->{"virtual_id"};

	    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}));

	    # Store reference so we can munge it below. 
	    $ifacemap{$node_nickname}->{$virtual_id} = $linkref;
	}
636
	
637
638
639
640
641
642
	#
	# Widearea nodes do not need to be allocated, but for now all
	# I allow is a plabdslice node.
	#
	if ($node->isremotenode()) {
	    if (! $node->isplabphysnode()) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
643
644
645
646
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Only plab widearea nodes");
		goto bad;
647
	    }
648
	    goto skipalloc;
649
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
650
651

	#
652
	# See if the node is already reserved. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
653
654
655
	#
	my $reservation = $node->Reservation();
	if (defined($reservation)) {
656
657
658
659
660
661
662
	    # Reserved during previous ticket operation, or already
	    # assigned to the slice (ticket redeemed).
	    goto skipalloc
		if ($reservation->SameExperiment($reserved_holding) ||
		    (defined($slice_experiment) &&
		     $reservation->SameExperiment($slice_experiment)));
	    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
663
664
665
666
	    $response =
		GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				     "$resource_uuid ($node) not available");
	    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
667
	}
668
669
670
671
672
	# watch for duplicates, as for multiple vnodes on a pnode.
	push(@nodeids, $node->node_id())
	    if (! grep {$_ eq $node->node_id()} @nodeids);

      skipalloc:
673
	$namemap{$node_nickname} = $node
674
	    if (defined($node_nickname));
675
676
677
678
	$colomap{$colocate} = $node
	    if (defined($colocate));
	delete($tofree{$node->uuid()})
	    if ($isupdate && exists($tofree{$node->uuid()}));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
679
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
680

Leigh B. Stoller's avatar
Leigh B. Stoller committed
681
682
683
684
685
686
687
688
689
690
691
    #
    # A sitevar controls how many total nodes external users can allocate.
    #
    # XXX All this policy stuff is a whack job for the initial release. 
    #
    my $max_externalnodes = 0;
    if (!TBGetSiteVar('protogeni/max_externalnodes', \$max_externalnodes)){
	# Cannot get the value, say none.
	$max_externalnodes = 0;
    }
    if (scalar(@nodeids) > $max_externalnodes) {
692
693
694
	$response = GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					 "Too many nodes; limited to $max_externalnodes");
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
695
696
    }
    # Check current usage by dipping into the libadminctrl library.
697
698
699
    my $curusage = libadminctrl::LoadCurrent($reserved_holding->creator(),
					     $reserved_holding->pid(),
					     $reserved_holding->gid());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
700
701
    if (!defined($curusage)) {
	print STDERR "Could not get current usage from adminctl library\n";
702
703
704
	$response = GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					 "Temporarily unavailable");
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
705
706
707
708
    }
    if ($curusage->{"nodes"}->{'project'} + scalar(@nodeids) >=
	$max_externalnodes) {
	my $nodesleft = $max_externalnodes - $curusage->{"nodes"}->{'project'};
709
710
711
	$response = GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					 "Too many nodes; limited to $nodesleft");
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
712
713
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
714
    # Nalloc might fail if the node gets picked up by someone else.
715
    if (@nodeids && !$impotent) {
716
	system("$NALLOC GeniSlices reservations @nodeids");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
717
	if (($? >> 8) < 0) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
718
719
720
721
	    $response =
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Allocation failure");
	    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
722
723
	}
	elsif (($? >> 8) > 0) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
724
725
726
727
	    $response =
		GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				     "Could not allocate node");
	    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
728
	}
729
730
731
	# In case the code below fails, before ticket is created.
	@dealloc = @nodeids;
    }
732
733
734
    goto skiplinks
	if (!exists($rspec->{'link'}));
    
735
736
737
738
    #
    # Now deal with links for wildcarded nodes. We need to fill in the
    # node_uuid.
    #
739
740
741
742
    foreach my $linkref (@{$rspec->{'link'}}) {
	my $nickname   = $linkref->{"nickname"} || $linkref->{"virtual_id"};
	my $interfaces = $linkref->{'linkendpoints'} ||
	    $linkref->{'interface_ref'};
743

744
745
746
747
748
749
750
751
752
753
754
	if (!defined($nickname)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtual_id for links");
	    goto bad;
	}
	
	foreach my $ref (@{ $interfaces }) {
	    my $node_nickname = $ref->{'virtual_node_id'} ||
		$ref->{'node_nickname'};
	    my $iface_id     = $ref->{'virtual_interface_id'} ||
		$ref->{'iface_name'};
755
756
	    my $istunnel      = (exists($linkref->{'link_type'}) &&
				 $linkref->{'link_type'} eq "tunnel");
757

758
	    if (!defined($node_nickname)) {
759
760
761
762
763
764
765
766
767
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$nickname: Need node id for links");
		goto bad;
	    }
	    if (!defined($iface_id)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$nickname: Need interface id for links");
768
769
770
		goto bad;
	    }

771
	    if ($istunnel) {
772
		# Might be the other side. Skip for now; might bite later.
773
774
		next
		    if (!exists($namemap{$node_nickname}));
775

776
777
778
779
780
781
782
783
784
		# Not doing anything else.
		next;
	    }
	    if (!exists($namemap{$node_nickname})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$nickname: No such virtual_node_id: ".
				 "$node_nickname:$iface_id");
		goto bad;
785
	    }
786
	    
787
	    #
788
	    # Sanity check the interface.
789
	    #
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
	    if (!exists($ifacemap{$node_nickname}->{$iface_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$nickname: No such interface on component: ".
				 "$node_nickname:$iface_id");
		goto bad;
	    }
	    my $node = $namemap{$node_nickname};
	    my $iface_ref  = $ifacemap{$node_nickname}->{$iface_id};
	    my $iface_name = $iface_ref->{"component_id"};

	    # Grab all the interfaces.
	    my @interfaces;
	    if ($node->AllInterfaces(\@interfaces) != 0) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not get interfaces for $node");
		goto bad;
	    }
	    # Make sure its valid, or fill in a wildcard.
	    foreach my $interface (@interfaces) {
		next
		    if (!defined($interface->switch_id()));
		next
		    if ($interface->role() ne "expt");
814

815
816
817
818
819
820
		if (defined($iface_name) && $iface_name ne "*") {

		}
		else {
		    $iface_name = $interface->iface();
		    $iface_ref->{"component_id"} = $iface_name;
821
822
823
		    last;
		}
	    }
824
825
826
827
828
829
	    if (!defined($iface_name)) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$nickname: Could not assign wildcard: ".
				 "$node_nickname:$iface_id");
		goto bad;
	    }
830
831
	}
    }
832
  skiplinks:
833
    #
834
    # Create a new ticket.
835
    #
836
837
    my $newticket = GeniTicket->Create($authority, $user, $rspec);
    if (!defined($newticket)) {
838
839
840
841
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not create GeniTicket object");
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
842
    }
843
    if ($newticket->Sign() || $newticket->Store()) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
844
845
846
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Could not sign Ticket");
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
847
    }
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863

    if ($isupdate) {
	#
	# Delete (not release) the old ticket. 
	#
	$ticket->Delete(TICKET_RELEASED)
	    if ($ticket->stored());

	# And release any nodes we no longer wanted.
	if (keys(%tofree)) {
	    my @ids = map { $_->node_id() } values(%tofree);

	    system("export NORELOAD=1; ".
		   "$NFREE -x -q GeniSlices reservations @ids");
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
864
    $slice->UnLock();
865
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $newticket->asString());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
866
  bad:
867
868
869
870
871
872
873
874
875
876
877
878
879
    #
    # Have to be careful in a ticket update, to not release nodes that
    # might be referenced in the old ticket. 
    #
    if ($isupdate) {
	if (defined($newticket)) {
	    # Delete, not Release (which frees nodes).
	    $newticket->Delete(TICKET_PURGED);
	}
	if (@dealloc) {
	    system("export NORELOAD=1; ".
		   "$NFREE -x -q GeniSlices reservations @dealloc");
	}
880
    }
881
882
883
884
885
886
887
888
889
    else {
	# Release will free the nodes.
	if (defined($newticket)) {
	    $newticket->Release(TICKET_PURGED);
	}
	elsif (@dealloc) {
	    system("export NORELOAD=1; ".
		   "$NFREE -x -q GeniSlices reservations @dealloc");
	}
890
    }
891
  unlock:
Leigh B. Stoller's avatar
Leigh B. Stoller committed
892
893
    $slice->UnLock()
	if (defined($slice));
894
895
    $ticket->UnLock()
	if (defined($ticket) && $ticket->stored());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
896
    return $response;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
897
898
899
}

#
900
# Redeem a ticket
Leigh B. Stoller's avatar
Leigh B. Stoller committed
901
#
902
sub RedeemTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
903
904
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
905

906
    return SliverWork($argref, 0);
907
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
908

909
#
910
# Update a sliver
911
912
913
914
#
sub UpdateSliver($)
{
    my ($argref) = @_;
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930

    return SliverWork($argref, 1);
}

#
# Utility function for above routines.
#
sub SliverWork($$)
{
    my ($argref, $isupdate) = @_;
    my $credstr    = $argref->{'credential'};
    my $ticketstr  = $argref->{'ticket'};
    my $impotent   = $argref->{'impotent'};
    my $keys       = $argref->{'keys'};
    my $extraargs  = $argref->{'extraargs'};
    my $didfwsetup = 0;
931
932
933
934

    $impotent = 0
	if (!defined($impotent));

935
    if (! (defined($credstr) && defined($ticketstr))) {
936
937
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
938
    my $credential = GeniCredential->CreateFromSigned($credstr);
939
    if (!defined($credential)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
940
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
941
942
943
944
945
946
947
948
949
				    "Could not create GeniCredential object");
    }
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
950
951
952
953
954
955
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "instantiate" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

956
957
958
959
960
961
962
963
    my $owner_uuid = $credential->owner_uuid();
    my $owner_cert = $credential->owner_cert();
    my $message    = "Error creating sliver/aggregate";

    my $ticket = GeniTicket->CreateFromSignedTicket($ticketstr);
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
964
    }
965
966
967
968
    # Only unredeemed tickets are stored in the DB.
    if (!$ticket->stored()) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This ticket was already redeemed!");
969
    }
970
971
    # Make sure the ticket was issued to the caller.
    if ($ticket->owner_uuid() ne $ENV{'GENIUUID'}) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
972
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
				    "This is not your ticket!");
    }
    # Make sure the ticket target is this Manager
    if ($ticket->target_uuid() ne $ENV{'MYUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "This ticket is for another authority!");
    }

    #
    # For now, there can be only a single toplevel aggregate per slice.
    #
    my $aggregate;
    my $slice;
    my $slice_uuid;
    
    if ($isupdate) {
	$aggregate = GeniAggregate->Lookup($credential->target_uuid());

	if (!defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Sliver cannot be found");
	}
	$slice_uuid = $aggregate->slice_uuid();
	$slice = GeniSlice->Lookup($slice_uuid);
	if (!defined($slice)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice record for $slice_uuid");
	}
    }
    else {
	$slice_uuid = $credential->target_uuid();
	$slice = GeniSlice->Lookup($slice_uuid);
	if (!defined($slice)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice record for $slice_uuid");
	}
	$aggregate  = GeniAggregate->SliceAggregate($slice);

	if (defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Already have an aggregate for slice");
	}
    }
    if ($ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1018
1019
    }
    if ($slice->Lock() != 0) {
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
	$ticket->UnLock();
	return GeniResponse->BusyResponse("slice");
    }

    # Do not redeem an expired ticket.
    if ($ticket->Expired()) {
	$slice->UnLock();
	$ticket->UnLock();
	return GeniResponse->Create(GENIRESPONSE_EXPIRED, undef,
				    "Ticket has expired");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1030
    }
1031
1032
1033
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
1034
	$ticket->UnLock();
1035
1036
1037
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1038

1039
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1040
    # Create the user.
1041
1042
1043
    #
    my $owner = GeniUser->Lookup($owner_uuid);
    if (!defined($owner)) {
1044
	$owner = CreateUserFromCertificate($owner_cert);
1045
1046
1047
1048
1049
	if (!defined($owner)) {
	    print STDERR "No user $owner_uuid in the ClearingHouse\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No user record for $owner_uuid");
	}
1050
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1051
1052
1053
    if (!$owner->IsLocal() && defined($keys)) {
	$owner->Modify(undef, undef, $keys);
    }
1054

1055
    my $experiment = GeniExperiment($slice);
1056
    if (!defined($experiment)) {
1057
1058
	$slice->UnLock();
	$ticket->UnLock();
1059
1060
1061
1062
1063
1064
1065
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local experiment for slice");
    }

    #
    # Figure out what nodes to allocate or free. 
    #
1066
1067
1068
    my %physnodes= ();
    my %nodemap  = ();
    my %linkmap  = ();
1069
    my %toalloc  = ();
1070
    my %colomap  = ();
1071
    my @allocated= ();
1072
1073
1074
    my @tofree   = ();
    my $pid      = $experiment->pid();
    my $eid      = $experiment->eid();
1075
    my $rspec    = $ticket->rspec();
1076
    my $needplabslice = 0;
1077
1078

    #
1079
    # Find current slivers and save.
1080
    #
1081
    if (defined($aggregate)) {
1082
	my @slivers;
1083
1084
1085
	if ($aggregate->SliverList(\@slivers) != 0) {
	    $message = "Could not get sliverlist for $aggregate";
	    goto bad;
1086
1087
1088
	}
	foreach my $s (@slivers) {
	    if (ref($s) eq "GeniSliver::Node") {
1089
		$nodemap{$s->nickname()} = $s;
1090
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1091
1092
	    elsif (ref($s) eq "GeniAggregate::Link" ||
		   ref($s) eq "GeniAggregate::Tunnel") {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1093
1094
		# XXX See the constructor in GeniAggregate.
		my ($linkname) = ($s->hrn() =~ /\.([-\w]*)$/);
1095
		$linkmap{$linkname} = $s;
1096
1097
	    }
	    else {
1098
1099
		$message = "Only nodes or links allowed";
		goto bad;
1100
1101
1102
1103
	    }
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1104
1105
1106
1107
1108
1109
1110
1111
    #
    # Figure out new expiration time; this is the time at which we can
    # idleswap the slice out. 
    #
    if (exists($rspec->{'valid_until'})) {
	my $expires = $rspec->{'valid_until'};

	if (! ($expires =~ /^[-\w:.\/]+/)) {
1112
1113
	    $message = "Illegal valid_until in rspec";
	    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1114
1115
1116
1117
	}
	# Convert to a localtime.
	my $when = timegm(strptime($expires));
	if (!defined($when)) {
1118
1119
1120
	    $message = "Could not parse valid_until";
	    goto bad;
					
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1121
1122
1123
1124
1125
1126
	}
	#
	# No more then 24 hours out ... Needs to be a sitevar?
	#
	my $diff = $when - time();
	if ($diff < (60 * 15) || $diff > (3600 * 24)) {
1127
1128
	    $message = "valid_until out of range";
	    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1129
1130
	}
	if ($slice->SetExpiration($when) != 0) {
1131
1132
	    $message = "Could not set expiration time";
	    goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1133
1134
1135
	}
    }

1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
    # Nodes are in this holding experiment.
    my $reserved_holding = Experiment->Lookup("GeniSlices", "reservations");
    if (!defined($reserved_holding)) {
	#
	# This experiment has to exist!
	#
	print STDERR "Could not find Geni reservations experiment!\n";
	goto bad;
    }

1146
    #
1147
    # Make sure all nodes requested are allocated. 
1148
1149
    #
    foreach my $ref (@{$rspec->{'node'}}) {
1150
1151
1152
1153
1154
1155
1156
1157
	my $resource_uuid = $ref->{'component_uuid'} || $ref->{'uuid'};
	my $node_nickname = $ref->{'virtual_id'} || $ref->{'nickname'};
	my $manager_uuid  = $ref->{'component_manager_uuid'};
	
	# Let remote nodes pass through.
	next
	    if (defined($manager_uuid) && $manager_uuid ne $ENV{'MYUUID'});

1158
1159
	my $node = Node->Lookup($resource_uuid);
	if (!defined($node)) {
1160
1161
	    $message = "Bad resource_uuid $resource_uuid";
	    goto bad;
1162
1163
	}

1164
1165
1166
1167
1168
1169
	#
	# Widearea nodes do not need to be allocated, but for now all
	# I allow is a plabdslice node.
	#
	if ($node->isremotenode()) {
	    if (! $node->isplabphysnode()) {
1170
1171
		$message = "Only plab widearea nodes";
		goto bad;
1172
1173
1174
1175
1176
	    }
	    $needplabslice = 1;
	    next;
	}

1177
1178
1179
1180
1181
1182
1183
1184
	#
	# See if the node is already reserved. 
	#
	my $reservation = $node->Reservation();
	if (defined($reservation)) {
	    # Reserved during previous operation on the sliver.
	    next
		if ($reservation->SameExperiment($experiment));
1185
1186
1187
1188
1189

	    # Need to move it into the experiment.
	    if ($reservation->SameExperiment($reserved_holding)) {
		$toalloc{$node->node_id()} = $node;
		next;
1190
	    }
1191
1192
	    $message = "$resource_uuid ($node) is not available";
	    goto bad;
1193
1194
1195
1196
	}
    }

    #
1197
1198
    # What *slivers* need to be released? This may result in physical
    # nodes being released later.