GeniCM.pm.in 112 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 GeniUsage;
37
use libtestbed qw(SENDMAIL);
38
use emutil;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
39
# Hate to import all this crap; need a utility library.
40
41
use libdb qw(TBGetSiteVar EXPTSTATE_SWAPPED EXPTSTATE_ACTIVE TBOPSPID
	     TBDB_NODESTATE_TBFAILED);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42
use User;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
43
use Node;
44
use Lan;
45
use OSinfo;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
46
use Image;
47
use Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
48
49
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
50
use XML::Simple;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
51
use Date::Parse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52
use POSIX qw(strftime tmpnam);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
53
use Time::Local;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
54
use Experiment;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
55
use VirtExperiment;
56
use Firewall;
57
58
use Compress::Zlib;
use MIME::Base64;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
59
60
61
62
63
64
65
66

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
67
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
68
my $CREATEEXPT     = "$TB/bin/batchexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
69
my $ENDEXPT        = "$TB/bin/endexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70
my $NALLOC	   = "$TB/bin/nalloc";
71
my $NFREE	   = "$TB/bin/nfree";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
my $AVAIL	   = "$TB/sbin/avail";
73
my $PTOPGEN	   = "$TB/libexec/ptopgen";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
75
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
76
77
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
78
my $EXPORTS_SETUP  = "$TB/sbin/exports_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
79
80
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
81
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
82
83
84
85
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
my $SNMPIT         = "$TB/bin/snmpit";
my $PRERENDER      = "$TB/libexec/vis/prerender";
86
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
87

88
89
90
91
92
93
94
95
96
97
98
99
my $API_VERSION = 1;

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

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
# Look up a node by an identifier of unspecified type (perhaps a URN, an
# (obsolete) UUID, or an old-style HRN.  Ultimately, all IDs should be
# URNs and this mess will go away, but for now we try not to make
# any assumptions, because of backward compatibility constraints.
sub LookupNode($)
{
    my ($nodeid) = @_;

    if( GeniHRN::IsValid( $nodeid ) ) {
	# Looks like a URN.
	my ($auth,$t,$id) = GeniHRN::Parse( $nodeid );

	return undef if $auth ne $OURDOMAIN or $t ne "node";

	return Node->Lookup( $id );
    }
 
    #
    # Looks like an old HRN, but we only want the last token for node lookup.
    #
    if ($nodeid =~ /\./) {
	($nodeid) = ($nodeid =~ /\.([-\w]*)$/);

	return Node->Lookup($nodeid);
    }
    
    # Assume it's a UUID, and pass it on as is.
    return Node->Lookup($nodeid);
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
130
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
131
# Respond to a Resolve request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
132
133
134
135
136
137
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
138
139
    my $type       = lc( $argref->{'type'} );
    my $hrn        = $argref->{'hrn'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
140
141
142
143

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
144
145
146
147
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
148
149
150
151
152
153
154
155
156
157
158
159
    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
160
161
162
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
163
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
	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!");
    }
184
    if ($type eq "node") {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
185
186
187
	my $node;
	
	if (defined($uuid)) {
188
	    $node= LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
189
190
	}
	else {
191
	    $node= LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
192
	}
193
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
194
195
196
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
197
198
199
200
201
202

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

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
222
223
224
225
226
227
228
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
    my $credential = $argref->{'credential'};
229
230
    my $available = $argref->{'available'} || 0;
    my $compress = $argref->{'compress'} || 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
231
232
233
234
235
236
237
238
    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.
239
    if ($user_uuid ne $credential->owner_uuid()) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
240
241
242
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }
243
244
245
246
247
248
249
    return DiscoverResourcesAux($available, $compress);
}
# Helper function for V2.
sub DiscoverResourcesAux($$)
{
    my ($available, $compress) = @_;
    my $user_uuid  = $ENV{'GENIUSER'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
250

251
252
253
    # 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.
254
255
256
257
258
259
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
260

Leigh B. Stoller's avatar
Leigh B. Stoller committed
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
    #
    # 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
278
    #
279
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
280
    #
281
282
    my $xml = GetAdvertisement($available, undef);
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
283
284
285
286
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

287
288
289
290
291
292
    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
293
294
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
295

296
297
298
299
300
301
302
303
#
# Use ptopgen in xml mode to spit back an xml file. 
#
sub GetAdvertisement($$)
{
    my ($available, $pc) = @_;
    my $xml = undef;

Jonathon Duerig's avatar
Jonathon Duerig committed
304
    my $invocation = "$PTOPGEN -x -g -r -p GeniSlices";
305
306
307
308
309
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
    if (open(AVAIL, "$invocation |")) {
310
	$xml = "";
311
312
313
314
315
316
317
318
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
    return $xml;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
319
#
320
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
321
#
322
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
323
324
{
    my ($argref) = @_;
325
326
327
328
329
330
331
332
333
334

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
335
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
336
    my $impotent   = $argref->{'impotent'};
337
338
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
339
340
341
342
343
344
345
    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
346

347
    if (! defined($credstr)) {
348
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
349
    }
350
    if (!defined($rspecstr)) {
351
352
	return GeniResponse->MalformedArgsResponse();
    }
353
354
355
356
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
357
    my $credential = GeniCredential->CreateFromSigned($credstr);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
358
359
360
361
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
362
363
364
    #
    # Make sure the credential was issued to the caller.
    #
365
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
366
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
367
				    "This is not your credential!");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
368
    }
369
    if ($isupdate) {
370
	$ticket = GeniTicket->CreateFromSignedTicket($tickstr);
371
372
373
374
375
	if (!defined($ticket)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create GeniTicket object");
	}
    }
376
    return GetTicketAux($credential,
377
			$rspecstr, $isupdate, $impotent, 0, 1, $ticket);
378
}
379

380
sub GetTicketAux($$$$$$$)
381
{
382
383
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level,
	$ticket) = @_;
384
    
385
386
387
388
389
390
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
391
    
392
393
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();
394
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
395
    #
396
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
397
398
399
    #
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
400
401
402
403
404
	if ($isupdate) {
	    print STDERR "Could not locate slice $slice_uuid for Update\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice found for UpdateTicket");
	}
405
	$slice = CreateSliceFromCertificate($credential);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
406
	if (!defined($slice)) {
407
	    print STDERR "Could not create $slice_uuid\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
408
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
409
					"Could not create slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
410
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
411
412
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
413
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
414
415
    # Ditto the user.
    #
416
    my $user = CreateUserFromCertificate($credential->owner_cert());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
417
    if (!defined($user)) {
418
419
420
421
422
	if ($isupdate) {
	    print STDERR "Could not locate $user_uuid for UpdateTicket\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No user found for UpdateTicket");
	}
423
	return GeniResponse->Create(GENIRESPONSE_ERROR);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
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
449
450
451
452
453
    return GetTicketAuxAux($slice, $user, $rspecstr,
			   $isupdate, $impotent, $v2, $level, $ticket);
}
sub GetTicketAuxAux($$$$$$$$)
{
    my ($slice, $user,
	$rspecstr, $isupdate, $impotent, $v2, $level, $ticket) = @_;
    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)) {
	print STDERR " Could not get uuid from $EMULAB_PEMFILE\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

    my $rspec =
	eval { XMLin($rspecstr, KeyAttr => [],
		     ForceArray => ["node", "link", "interface",
				    "interface_ref", "linkendpoints"]) };
    if ($@) {
	print STDERR "XMLin error: $@\n";
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "XML error in rspec");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
454

Leigh B. Stoller's avatar
Leigh B. Stoller committed
455
456
457
458
459
460
461
462
463
464
465
466
467
468
    #
    # 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");
    }
    
    #
469
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
    # 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");
	}
	
	#
487
	# Do we need a policy limit?
Leigh B. Stoller's avatar
Leigh B. Stoller committed
488
489
	#
	my $diff = $when - time();
490
	if ($diff < (60 * 5) || $diff > (3600 * 24 * 100)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
491
492
493
494
495
496
497
498
499
	    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)));
    }
500
501
502
503
504
505
506

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
507
508
509
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
510
511
512
513
514
515
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
516
517
518
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
519
    }
520
521
522
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
523
524
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
525
526
527
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
528

529
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
530
    # For now, there can be only a single toplevel aggregate per slice.
531
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
532
    #
533
    my $aggregate = GeniAggregate->SliceAggregate($slice);
534
535
536
537
538
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
539
540
	}
    }
541
542
543
544
545
    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;
    }
546
547
548
549
550
551

    #
    # Firewall hack; just a flag in the rspec for now.
    #
    if (exists($rspec->{'needsfirewall'}) && $rspec->{'needsfirewall'}) {
	if ($slice->SetFirewallFlag($rspec->{'needsfirewall'}) != 0) {
552
553
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
554
555
	}
    }
556
557

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
558
    # We need this now so we can form a virtual topo.
559
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
560
561
562
563
564
565
566
567
    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();
568
569
570
571
572
573
574
575
576
577
578

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
    if (exists($rspec->{'generated_by'}) &&
	$rspec->{'generated_by'} eq "libvtop") {
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
579
580
581
582
583
584
585
586
587
588
589
590
591
    
    #
    # 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);
592
    $virtexperiment->multiplex_factor(3);
593
594

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
598
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
599
600
    # 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
601
602
    # cannot be granted.
    #
603
604
605
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
606
    my %nodemap  = ();
607
    my @nodeids  = ();
608
    my %lannodes = ();
609
    my @dealloc;
610
611
612
613
614
615
616
617

    #
    # 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
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
	$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;
	}
636
637
638
639
640
641
642
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
643
	
644
	foreach my $ref (@{$oldrspec->{'node'}}) {
645
646
647
648
649
650
	    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.
651
	    next
652
653
654
		if (defined($manager_uuid) &&
		    !GeniHRN::Equal( $manager_uuid, $ENV{'MYURN'} ) &&
		    $manager_uuid ne $ENV{'MYUUID'});
655

656
657
658
659
660
661
	    # Skip lan nodes; they are fake.
	    next
		if (exists($ref->{'node_type'}) &&
		    exists($ref->{'node_type'}->{'type_name'}) &&
		    $ref->{'node_type'}->{'type_name'} eq "lan");

662
	    my $node = LookupNode($resource_uuid);
663
664
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
665
				 "Bad resource $resource_uuid in ticket");
666
667
668
		goto bad;
	    }

669
670
671
672
673
674
	    #
	    # 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.
	    #
675
	    my $reservation = $node->Reservation();
676
	    if (defined($reservation) &&
677
		defined($reserved_holding) &&
678
679
680
681
682
683
		$reservation->SameExperiment($reserved_holding)) {
		if ($node->MoveReservation($slice_experiment)) {
		    print STDERR "Could not move $node to $slice_experiment\n";
		    goto bad;
		}
		$node->Refresh();
684
685
686
687
688
689
	    }
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
690

Leigh B. Stoller's avatar
Leigh B. Stoller committed
691
692
    print STDERR Dumper($rspec);

693
    foreach my $ref (@{$rspec->{'node'}}) {
694
695
696
697
	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'};
698
	my $subnode_of    = $ref->{'subnode_of'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
699
700
701
	my $virtualization_type    = $ref->{'virtualization_type'};
	my $virtualization_subtype = $ref->{'virtualization_subtype'};
	my $exclusive     = $ref->{'exclusive'};
702
	my $pctype;
703
	my $osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
704
705
	my $node;

706
	# Let remote nodes pass through.
707
	next
708
709
710
	    if (defined($manager_uuid) &&
		!GeniHRN::Equal( $manager_uuid, $ENV{'MYURN'} ) &&
		$manager_uuid ne $ENV{'MYUUID'});
711

712
713
714
715
716
717
718
719
720
721
722
723
	#
	# 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. 
	#
	if (exists($ref->{'node_type'}) &&
	    exists($ref->{'node_type'}->{'type_name'}) &&
	    $ref->{'node_type'}->{'type_name'} eq "lan") {
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
724
725
726
	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
727
728
		    $pctype = "pcvm";
		    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
729
730
731
732
733
734
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
			$osname = "OPENVZ-STD";
		    }
735
736
737
738
739
740
741
		    elsif ($virtualization_subtype eq "emulab-spp") {
			$osname = "SPPVM-FAKE";
			$pctype = "sppvm";
			# Lets force to shared node.
			$ref->{'exclusive'} = $exclusive = 0;
			# Kludge for libvtop.
			$virtexperiment->multiplex_factor(1);
742
			$virtexperiment->encap_style("vlan");
743
		    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
744
745
746
747
748
749
750
751
752
753
754
755
756
757
		}
		else {
		    goto raw;
		}
	    }
	    else {
	      raw:
		# Lets force to exclusive real node.
		$ref->{'exclusive'} = $exclusive = 1;
		$ref->{'virtualization_type'} = "raw";
	    }
	}
	else {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
758
				     "Must provide a virtualization_type");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
759
760
761
	    goto bad;

	}
762
763
764
765
766
767
	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
768
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
769
	# Allow wildcarding.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
770
	#
771
772
773
774
775
776
	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};
777
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
778
779
	}
	else {
780
	    $node = LookupNode($resource_uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
781
782
783
784
785
786
787

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad resource $resource_uuid");
		goto bad;
	    }
788
789
	    $pctype = $node->type()
		if (!defined($pctype));
790
791
	}
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
792
	# If no osname by this point, try for the default.
793
794
	#
	if (defined($node) && !defined($osname)) {
795
796
797
798
799
	    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
800
	}
801
802
803
	# The slot does not like to be NULL.
	$osname = ""
	    if (!defined($osname));
804
	
805
806
807
	# Need some kind of default.
	$pctype = "pc"
	    if (!defined($pctype));
808
	
809
810
811
812
813
	my $nodeblob = {"vname"   => $node_nickname,
			"type"    => $pctype,
			"osname"  => $osname,
			"ips"     => '', # deprecated
			"cmd_line"=> '', # bogus
Leigh B. Stoller's avatar
Leigh B. Stoller committed
814
815
			"fixed"   => (defined($subnode_of) ? $subnode_of :
				      defined($node) ? $node->node_id() : ""),
816
			};
817
818

	# Tarball and startup command.
819
	if (exists($ref->{'startup_command'})) {
820
821
822
823
824
825
826
827
828
829
830
831
832
833
	    my $startupcmd = $ref->{'startup_command'};
	    
	    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;
	}
	if (exists($ref->{'tarfiles'})) {
	    my $tarfiles = $ref->{'tarfiles'};
	    
834
	    if (! TBcheck_dbslot($tarfiles, "virt_nodes", "tarfiles",
835
836
837
838
839
840
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Invalid tarfiles");
		goto bad;
	    }
841
	    $nodeblob->{'tarfiles'} = $tarfiles;
842
843
844
845
846
847
848
849
	}

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
851
852
853
854
855
856
857
858
859
860
	$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};
	
861
862
863
864
	#
	# Look for interface forward declarations that will be used later
	# in the link specifications. 
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
865
866
867
	next
	    if (!exists($ref->{'interface'}));
	
868
869
870
871
872
873
874
875
876
877
878
879
880
	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}));

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

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
888
889
	    # This is used after the mapper runs since it uses vname:vport.
	    $ifacemap{"$node_nickname:$vport"} = $linkref;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
890
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
891
892
    }

893
894
895
    goto skiplinks
	if (!exists($rspec->{'link'}));
    
896
897
898
899
    #
    # Now deal with links for wildcarded nodes. We need to fill in the
    # node_uuid.
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
900
901
    my $linknum = 1;
    
902
    foreach my $linkref (@{$rspec->{'link'}}) {
903
	my $lanname    = $linkref->{"nickname"} || $linkref->{"virtual_id"};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
904
905
	my $istunnel   = (exists($linkref->{'link_type'}) &&
			  $linkref->{'link_type'} eq "tunnel");
906
907
	my $interfaces = $linkref->{'linkendpoints'} ||
	    $linkref->{'interface_ref'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
908
	my $ifacenum   = 1;
909
	my $trivial_ok = 0;
910

911
	if (!defined($lanname)) {
912
913
914
915
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtual_id for links");
	    goto bad;
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
916

917
918
919
920
921
922
923
	#
	# Ick. Before we create the virt_lan_lans entry, we have to check
	# inside to see if one of the interfaces is connected to a lan
	# node. In this case, we want to reuse (if its been created) the
	# lan name, rather then a bunch of links with one interface, which
	# would result in a bogus topology. 
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
924
	if (!$istunnel) {
925
926
927
928
929
930
931
932
933
934
935
936
	    foreach my $ref (@{ $interfaces }) {
		my $node_nickname = $ref->{'virtual_node_id'} ||
		    $ref->{'node_nickname'};

		if (exists($lannodes{$node_nickname})) {
		    $lanname = $node_nickname;
		}
	    }
	    if (!defined($virtexperiment->Find("virt_lan_lans", $lanname))) {
		$virtexperiment->NewTableRow("virt_lan_lans",
					     {"vname" => $lanname});
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
937
	}
938
939
940
941
942
943
	
	foreach my $ref (@{ $interfaces }) {
	    my $node_nickname = $ref->{'virtual_node_id'} ||
		$ref->{'node_nickname'};
	    my $iface_id     = $ref->{'virtual_interface_id'} ||
		$ref->{'iface_name'};
944

945
	    if (!defined($node_nickname)) {
946
947
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
948
				 "$lanname: Need node id for links");
949
950
951
952
953
		goto bad;
	    }
	    if (!defined($iface_id)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
954
				 "$lanname: Need interface id for links");
955
956
957
		goto bad;
	    }

958
959
960
961
962
963
964
965
966
	    #
	    # Look for links that are really lans; one of the interfaces
	    # is on a fake lan node, which we caught above. Just skip it
	    # since in the virt topo, a lan is just a link with more then
	    # two nodes.
	    #
	    next
		if (exists($lannodes{$node_nickname}));

967
	    if ($istunnel) {
968
		# Might be the other side. Skip for now; might bite later.
969
970
		next
		    if (!exists($namemap{$node_nickname}));
971

972
973
974
		# Not doing anything else.
		next;
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
975
	    if (!exists($ifacemap{$node_nickname})) {
976
977
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
978
				 "$lanname: No such virtual_node_id: ".
Leigh B. Stoller's avatar
Leigh B. Stoller committed
979
				 "$node_nickname");
980
		goto bad;
981
	    }
982
	    
983
	    #
984
	    # Sanity check the interface.
985
	    #
986
987
988
	    if (!exists($ifacemap{$node_nickname}->{$iface_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
989
				 "$lanname: No such interface on component: ".
990
991
992
				 "$node_nickname:$iface_id");
		goto bad;
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
993
994
	    my $iface_ref   = $ifacemap{$node_nickname}->{$iface_id}->{"rspec"};
	    my $iface_name  = $iface_ref->{"component_id"} || "";
995
	    if( GeniHRN::IsValid( $iface_name ) ) {
996
997
		my ($urn_authority,$urn_node,$urn_iface) =
		    GeniHRN::ParseInterface( $iface_name );
998
999
		$iface_name = $urn_iface;
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1000
1001
1002
1003
1004
1005
	    my $iface_vport = $ifacemap{$node_nickname}->{$iface_id}->{"vport"};

	    # XXX
	    my $ip     = "10.10.${linknum}.${ifacenum}";
	    my $mask   = "255.255.255.0";
	    my $member = "$node_nickname:$iface_vport";
1006
1007
1008
1009
1010
	    my $bandwidth = 100000;

	    # Let user override.
	    $bandwidth = $linkref->{'bandwidth'}
	        if (exists($linkref->{'bandwidth'}));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1011
1012
	    
	    $virtexperiment->NewTableRow("virt_lans",
1013
					 {"vname"       => $lanname,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1014
1015
					  "vnode"       => $node_nickname,
					  "vport"       => $iface_vport,
1016
					  "trivial_ok"  => $trivial_ok,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1017
1018
					  "ip"          => $ip,
					  "delay"       => 0.0,
1019
					  "bandwidth"   => $bandwidth, # kbps
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1020
1021
1022
1023
					  "lossrate"    => 0.0,
					  "member"      => $member,
					  "mask"        => $mask,
					  "rdelay"      => 0.0,
1024
					  "rbandwidth"  => $bandwidth, # kbps
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1025
1026
1027
1028
1029
1030
1031
1032
					  "rlossrate"   => 0.0,
					  "fixed_iface" => $iface_name});
	    $ifacenum++;
	}
	$linknum++;
    }
  skiplinks:
    $virtexperiment->Dump();
1033
1034
1035
1036
    if ($virtexperiment->Store()) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	goto bad;
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1037
1038
1039
1040
1041
1042

    # Must chdir to the work directory for the mapper.
    if (! chdir($slice_experiment->WorkDir())) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	goto bad;
    }
1043

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1044
1045
1046
    # Do a render cause its nice to have on the show experiment page.
    system("$PRERENDER -r $pid $eid");
    system("$PRERENDER -t $pid $eid");
1047

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
    #
    # Now run the mapper in impotent mode. The idea is get a solution
    # without allocating any nodes. If we get a solution, and we can
    # allocate the nodes, we update the rspec with the physical info.
    #
    my $tmpfile = POSIX::tmpnam();

    # First a prerun to get the node counts and verify topo.
    system("$VTOPGEN -p $pid $eid");
    if ($?) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not verify topo");
	goto bad;
    }
1063
    system("$MAPPER -n -d -v -u -o $tmpfile $pid $eid");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1064
1065
1066
1067
1068
1069
1070
1071
    if ($?) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not map to resources");
	unlink($tmpfile);
	if ($isupdate) {
	    $slice_experiment->RemovePhysicalState();
	    $slice_experiment->RestorePhysicalState();
1072
	}
1073
1074
1075
1076
1077
1078
1079
1080
	# Dump the vtop.
	if (-e "$pid-$eid.vtop") {
	    print STDERR "----------------------------------------------\n";
	    print STDERR "------------------ Vtop File -----------------\n";
	    my $log = `cat $pid-$eid.vtop`;
	    print STDERR $log . "\n";
	    print STDERR "----------------------------------------------\n";
	}	    
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
	#
	# Lets dump the error log too, so it ends up in the email.
	# Have to figure out a better approach for this.
	#
	if (-e "assign.log") {
	    print STDERR "----------------------------------------------\n";
	    print STDERR "------------- Assign Error Log ---------------\n";
	    my $log = `cat assign.log`;
	    print STDERR $log . "\n";
	    print STDERR "----------------------------------------------\n";
	}	    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1092
	goto bad;
1093
    }
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
    my $solution =
	eval { XMLin($tmpfile, KeyAttr => [],
		     ForceArray => ["node", "link", "interface",
				    "interface_ref", "linkendpoints"]) };
    if ($@) {
	print STDERR "XMLin error: $@\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "XML error in solution");
	goto bad;
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1105
1106
1107
1108
1109
1110
    unlink($tmpfile);
    print Dumper($solution);

    foreach my $ref (@{$solution->{'node'}}) {
	my $virtual_id     = $ref->{"virtual_id"};
	my $component_uuid = $ref->{"component_uuid"};
1111
1112
1113
1114
1115
1116
	if (!exists($nodemap{$virtual_id})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Mapper inserted nodes you did not want");
	    goto bad;
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1117
1118
	my $rspec          = $nodemap{$virtual_id}->{'rspec'};
	my $virtnode       = $nodemap{$virtual_id}->{'virtnode'};
1119
	my $node           = LookupNode($component_uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1120
1121
	my $colocate       = $rspec->{'colocate'} ||
	    $rspec->{'phys_nickname'};
1122
	my $exclusive      = $rspec->{'exclusive'};