GeniCM.pm.in 183 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2008-2013 University of Utah and the Flux Group.
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
# 
# {{{GENIPUBLIC-LICENSE
# 
# GENI Public License
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and/or hardware specification (the "Work") to
# deal in the Work without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Work, and to permit persons to whom the Work
# is furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Work.
# 
# THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE WORK OR THE USE OR OTHER DEALINGS
# IN THE WORK.
# 
# }}}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#
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 ( );

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

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

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

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
150
151
152
153
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
154
155
156
157
158
159
160
161
162
163
164
165
    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
166
167
168
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
169
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
170
171
172
173
174
175
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

176
177
178
179
    my $credential = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

180
    if ($type eq "node") {
181
	require Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
182
183
184
	my $node;
	
	if (defined($uuid)) {
185
	    $node= GeniUtil::LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
186
187
	}
	else {
188
	    $node= GeniUtil::LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
189
	}
190
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
191
192
193
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
194

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

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
220
221
222
223
224
225
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
226
    my $credstr   = $argref->{'credential'};
227
    my $available = $argref->{'available'} || 0;
228
    my $compress  = $argref->{'compress'} || 0;
229
    my $version   = $argref->{'rspec_version'} || undef;
230
231
232
233

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

235
236
    return DiscoverResourcesAux($available,
				$compress, $version, [$credential]);
237
238
}
# Helper function for V2.
239
sub DiscoverResourcesAux($$$$)
240
{
241
    my ($available, $compress, $version, $credentials) = @_;
242
    my $user_urn  = $ENV{'GENIRN'};
243
    $version   = "2"
244
245
246
	if (!defined($version));

    # Sanity check since this can come from client.
247
    if (! ($version eq "0.1" || $version eq "0.2" || $version eq "2"
248
249
250
	   || $version eq "3"
	   || $version eq "PG 0.1" || $version eq "PG 0.2"
	   || $version eq "PG 2")) {
251
252
253
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper version request");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
254

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
265
266
267
268
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
269
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
270
271
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
272
    }
273
274
275
276
277
278
279

    # 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) {
280
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
281
282
283
284
285
286
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
287
	my $user = GeniUser->Lookup($user_urn, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
288
289
290
291
292
293
294
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
    #
    # See if one of the credentials is a slice credential. If it is, and
    # that slice is active, pass it to ptopgen so that it includes the current
    # resources as available.
    #
    my $experiment = undef;
    foreach my $credential (@$credentials) {
	my ($auth, $type, $id) = GeniHRN::Parse($credential->target_urn());
	if ($type eq "slice") {
	    # Might not exist here yet.
	    my $slice = GeniSlice->Lookup($credential->target_urn());
	    if (defined($slice)) {
		# See if the local experiment exists yet.
		$experiment = Experiment->Lookup($slice->uuid());
	    }
	    last;
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
314
    #
315
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
316
    #
317
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
318
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
319
320
321
322
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

323
324
325
326
327
328
    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
329
330
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
331

332
333
334
#
# Use ptopgen in xml mode to spit back an xml file. 
#
335
sub GetAdvertisement($$$$)
336
{
337
    my ($available, $pc, $version, $experiment) = @_;
338
    my $xml = undef;
339
340
    my $gotlock = 0;
    my $filename = "/var/tmp/protogeni_resources.xml";
341

342
343
344
345
346
347
348
    $version = "0.1"
	if ($version eq "PG 0.1");
    $version = "0.2"
	if ($version eq "PG 0.2");
    $version = "2"
	if ($version eq "PG 2");

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
428
#
429
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
430
#
431
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
432
433
{
    my ($argref) = @_;
434
435
436
437
438
439
440
441
442
443

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
444
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
445
    my $impotent   = $argref->{'impotent'};
446
447
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
448
449
450
451
452
453
454
    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
455

456
    if (! defined($credstr)) {
457
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
458
    }
459
    if (!defined($rspecstr)) {
460
461
	return GeniResponse->MalformedArgsResponse();
    }
462
463
464
465
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
466
467
468
469
    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

470
    if ($isupdate) {
471
	$ticket = CheckTicket($tickstr, $credential->target_urn());
472
473
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
474
    }
475
    return GetTicketAux($credential,
476
			$rspecstr, $isupdate, $impotent, 0, 1, $ticket);
477
}
478

479
sub GetTicketAux($$$$$$$)
480
{
481
482
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level,
	$ticket) = @_;
483
    
484
485
486
487
488
489
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
490
    
491
492
    my $slice_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
493
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
494
    #
495
    # Create user from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
496
    #
497
    my $user = CreateUserFromCertificate($credential);
498
499
    return $user
	if (GeniResponse::IsResponse($user));
500
501
502

    # Bump activity. Does not matter if request fails ...
    $user->BumpActivity();
503
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
504
    #
505
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
506
    #
507
508
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
509
	if ($isupdate) {
510
	    print STDERR "Could not locate slice $slice_urn for Update\n";
511
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
512
513
514
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
515
516
	return $slice
	    if (GeniResponse::IsResponse($slice));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
517
    }
518
    main::AddLogfileMetaDataFromSlice($slice);
519
    
520
    return GetTicketAuxAux($slice, $user, $rspecstr,
521
522
			   $isupdate, $impotent, $v2, $level, $ticket,
			   [$credential]);
523
}
524
sub GetTicketAuxAux($$$$$$$$$)
525
{
526
527
    my ($slice, $user, $rspecstr, 
        $isupdate, $impotent, $v2, $level, $ticket, $credentials) = @_;
528
529
530
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
531
    require OSinfo;
532
    require Image;
533
    require VirtExperiment;
534
535
536
537
538
539

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

544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
    #
    # 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");
    }

562
563
    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
564
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
565
				    "Error Parsing rspec XML");
566
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
567

568
569
570
571
572
573
    my $rspecVersion = GeniXML::GetXmlVersion($rspec);
    if (! defined($rspecVersion)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Unknown RSpec Version");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
574
575
576
577
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
578
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
579
580
581
582
583
584
585
586
587
588
589
590
591
592
	    # 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
593
    }
594
595
596

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
597
598
599
600
				    "External users temporarily denied");
    }
    
    #
601
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
602
    # ticket is redeemed, it will expire according to the rspec request.
603
604
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
605
606
    # slice credential, or the local policy max_sliver_lifetime. See
    # CreateSliceFromCertificate() in this file.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
607
    #
Jonathon Duerig's avatar
Jonathon Duerig committed
608
    my $expires = GeniXML::GetExpires($rspec);
609
    if (defined($expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
610
611
612
613
614
615
616
617
618
619
620
621
	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");
	}
	
	#
622
	# Do we need a policy limit?
Leigh B Stoller's avatar
Leigh B Stoller committed
623
624
625
626
627
	# A sitevar controls the sliver lifetime.
	#
	my $max_sliver_lifetime = 0;
	if (!GetSiteVar('protogeni/max_sliver_lifetime',
			\$max_sliver_lifetime)){
628
629
	    # Cannot get the value, default it to 90 days.
	    $max_sliver_lifetime = 90;
Leigh B Stoller's avatar
Leigh B Stoller committed
630
631
632
633
634
635
636
637
638
639
640
641
642
	}

	# 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) {
	    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;
	    }
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
643
	my $diff = $when - time();
644
645
646
647
648
649
	if ($diff < (60 * 5)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"such a short life for a sliver? ".
					"More time please.");
	}
	elsif ($diff > (3600 * 24 * $max_sliver_lifetime)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
650
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
651
652
			"expiration is greater then the maximum number ".
			"of minutes " . (60 * 24 * $max_sliver_lifetime));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
653
	}
654
655
656
657
658
659

	#
	# Must be before the slice expires.
	#
	my $slice_expires = $slice->expires();
	if (defined($slice_expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
660
	    $slice_expires = str2time($slice_expires);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
661
	    if ($when > $slice_expires) {
662
663
664
665
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "valid_until is past slice expiration");
	    }
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
666
    }
667
668
669
670
671
672
673

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

704
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
705
    # For now, there can be only a single toplevel aggregate per slice.
706
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
707
    #
708
    my $aggregate = GeniAggregate->SliceAggregate($slice);
709
710
711
712
713
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
714
715
	}
    }
716
717
718
719
720
    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;
    }
721

722
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
723
    # We need this now so we can form a virtual topo.
724
    #
725
726
727
728
729
730
731
732
733
734
735
    my $slice_experiment = GeniExperiment($slice, $user);
    if (GeniResponse::IsResponse($slice_experiment)) {
	$response = $slice_experiment;
	$slice_experiment = undef;
	goto bad;
    }
    my $realuser = FlipToUser($slice, $user);
    if (! (defined($realuser) && $realuser)) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "FlipToUser Error");
	print STDERR "Error flipping to real user\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
736
737
738
739
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
740
741
742
743
744

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
745
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
746
747
    if (defined($generated_by) &&
	$generated_by eq "libvtop") {
748
749
750
751
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
752
753
754
755
756
757
758
759
760
761
762
763
764
    
    #
    # 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);
765
    $virtexperiment->multiplex_factor(10);
766

767
768
769
770
771
772
773
774
775
776
    #
    # Add global vtypes.
    #
    my $vtypes_result =
	emdb::DBQueryWarn("select * from global_vtypes");
    if (!$vtypes_result) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    while (my $row = $vtypes_result->fetchrow_hashref()) {
777
	$virtexperiment->NewTableRow("virt_vtypes",
778
779
780
781
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
782
    }
783

784
785
786
787
788
    # Need to move this someplace else; the parser adds a bunch.
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "ns",
				  "objecttype" => "6"});
789

Leigh B. Stoller's avatar
Leigh B. Stoller committed
790
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
791
792
    # 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
793
794
    # cannot be granted.
    #
795
796
797
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
798
    my %iface2node = ();
799
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
800
    my %nodemap  = ();
801
    my %bridgemap= ();
802
    my @nodeids  = ();
803
    my %lannodes = ();
804
    # For stitching, keep track of external nodes and links.
805
806
807
808
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
    my %stitching_paths   = ();
809

810
811
812
    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();
    
813
814
815
816
817
818
819
    #
    # 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
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
	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;
	}
837
838
839
840
841
842
843
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
844
	
845
	foreach my $ref (GeniXML::FindNodes("n:node",
846
					    $oldrspec)->get_nodelist()) {
847
	    # Let remote nodes pass through.
848
	    next
849
		if (!GeniXML::IsLocalNode($ref));
850

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

855
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
856
	    my $colocate      = GeniXML::GetColocate($ref);
857
	    my $component_id  = GeniXML::GetNodeId($ref);
858
859
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
860
861
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
862
				 "Bad resource $component_id in ticket");
863
864
		goto bad;
	    }
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
	    #
	    # Is the node a virtual node? Must be an update to an
	    # existing sliver/ticket, since we now return the node_id
	    # of the allocated virtual node, not the physical node.
	    #
	    if ($node->isvirtnode()) {
		my $pnode = Node->Lookup($node->phys_nodeid());
		if (!defined($pnode)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "No physical resource for $component_id");
		    goto bad;
		}
		$node = $pnode;
	    }
880
881
882
883
884
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
885

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

888
889
    my %nodeexistsmap = ();

890
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
891
	my $component_id  = GeniXML::GetNodeId($ref);
892
	my $vnode_id      = GeniXML::GetVnodeId($ref);
893
	my $manager_id    = GeniXML::GetManagerId($ref);
894
	my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
895
896
897
898
	my $colocate      = GeniXML::GetColocate($ref);
	my $subnode_of    = GeniXML::GetSubnodeOf($ref);
	my $virtualization_type = GeniXML::GetVirtualizationType($ref);
	
899
	my $virtualization_subtype
Jonathon Duerig's avatar
Jonathon Duerig committed
900
901
                          = GeniXML::GetVirtualizationSubtype($ref);
	my $exclusive     = GeniXML::GetExclusive($ref);
902
	my $tarfiles      = GeniXML::GetTarball($ref);
903
	my $pctype;
904
	my ($osname, $osinfo);
905
	my $parent_osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
906
	my $node;
907
908
909
	my $isbridge    = 0;
	my $isfirewall  = 0;
	
910
	if (exists($nodeexistsmap{lc($node_nickname)})) {
911
912
913
914
915
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate node $node_nickname");
	    goto bad;
	}
916
	$nodeexistsmap{lc($node_nickname)} = 1;
917

918
919
920
921
922
	# Always populate iface2node mapping, even if we let the node
	# pass through.
	foreach my $linkref (GeniXML::FindNodes("n:interface",
						$ref)->get_nodelist()) {
	    my $virtual_id   = GeniXML::GetInterfaceId($linkref);
923
924
925
926
927
928
929
	    if (exists($iface2node{$virtual_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Duplicate interface $virtual_id on ".
					 "node $node_nickname");
		goto bad;
	    }
930
931
932
	    $iface2node{$virtual_id} = $node_nickname;
	}

933
	# Let remote nodes pass through.
934
935
936
937
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}
938

939
	#
940
941
942
943
944
	#
	# 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. 
	#
945
	if (GeniXML::IsLanNode($ref)) {
946
947
948
949
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

950
951
952
	#
	# Check for disk_image request. Specified as a URN. 
	#
953
	my $diskref = GeniXML::GetDiskImage($ref);
954
955
	if (defined($diskref)) {
	    my $dname = GeniXML::GetText("name", $diskref);
956
	    my $url   = GeniXML::GetText("url", $diskref);
957

958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
	    if (defined($url)) {
		if (! TBcheck_dbslot($url, "virt_nodes", "osname",
				 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid disk image url: $url");
		    goto bad;
		}
		#
		# Pass it right through; we load them later.
		# There is no osinfo, but see below. 
		#
		$osname = $url;
	    }
	    elsif (defined($dname)) {
973
974
975
976
977
978
979
980
981
982
983
984
985
986
		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;
		}
987
		$osinfo = OSinfo->Lookup($ospid, $os);
988
		if (!defined($osinfo)) {
989
990
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
991
					     "Unknown image URN: $dname");
992
993
		    goto bad;
		}
994
995
996
997
998
999
		#
		# The OS must be in the current project, or it must
		# be global (okay, shared).
		#
		if (! ($osinfo->shared() ||
		       $osinfo->pid() eq $slice_experiment->pid())) {
1000
1001
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
1002
				 "Insufficient permission to use $osinfo");
1003
1004
		    goto bad;
		}
1005
		
1006
1007
1008
		#
		# This is only going to be used in raw mode. 
		#
1009
		$osname = "$ospid/$os";
1010
1011
1012
	    }
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
1013
1014
1015
	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
1016
1017
		    $pctype = "pcvm";
		    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1018
1019
1020
1021
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
1022
1023
1024
1025
1026
1027
1028
1029
			# Allow caller to set the image to use, but also
			# trick to set the parent. 
			if (defined($osinfo)) {
			    if (! $osinfo->IsSubOS()) {
				$parent_osname = $osname;
				$osname = "OPENVZ-STD";
			    }
			}
1030
1031
			elsif (!defined($osname)) {
			    # Allow for url above.
1032
1033
			    $osname = "OPENVZ-STD";
			}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1034
		    }
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
		    elsif ($virtualization_subtype eq "emulab-xen") {
			# Allow caller to set the image to use, but also
			# trick to set the parent. 
			if (defined($osinfo)) {
			    if (! $osinfo->IsSubOS()) {
				$parent_osname = $osname;
				$osname = "XEN-STD";
			    }
			}
			elsif (!defined($osname)) {
			    # Allow for url above.
			    $osname = "XEN-STD";
			}
		    }
1049
1050
1051
1052
		    elsif ($virtualization_subtype eq "emulab-spp") {
			$osname = "SPPVM-FAKE";
			$pctype = "sppvm";
			# Lets force to shared node.
Jonathon Duerig's avatar
Jonathon Duerig committed
1053
			if (! GeniXML::SetExclusive($ref, 0)) {
1054
1055
1056
			    $response
				= GeniResponse->Create(GENIRESPONSE_BADARGS,
						       undef,
1057
1058
				       "Malformed rspec: ".
				       "Cannot set exclusive tag to false");
1059
1060
1061
			    goto bad;
			}
			$exclusive = 0;
1062
1063
			# Kludge for libvtop.
			$virtexperiment->multiplex_factor(1);
1064
			$virtexperiment->encap_style("vlan");
1065
		    }
1066
1067
1068
1069
1070
1071
		    elsif ($virtualization_subtype eq "emulab-bbg") {
			$osname = "BBGENIVM-FAKE";
			$pctype = "bbgenivm";
			# Lets force to shared node.
			GeniXML::SetExclusive($ref, 0);
			$exclusive = 0;
1072
			$virtexperiment->multiplex_factor(5);
1073
1074
			$virtexperiment->encap_style("vlan");
		    }
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
		    elsif ($virtualization_subtype eq "emulab-connect") {
			$osname = "GENERICDEV-VM";
			$pctype = "interconnect-vm";
			# Lets force to shared node.
			GeniXML::SetExclusive($ref, 0);
			$exclusive = 0;
			# Kludge for libvtop.
			$virtexperiment->multiplex_factor(5);
			$virtexperiment->encap_style("vlan");
		    }
1085
1086
		    elsif ($virtualization_subtype eq "raw"
			   || $virtualization_subtype eq "raw-pc") {
1087
1088
1089
			$pctype = undef;
			goto raw;
		    }
1090
1091
1092
1093
		    elsif ($virtualization_subtype eq "delay") {
			$isbridge = 1;
			$pctype   = undef;
		    }
1094
1095
1096
1097
1098
1099
		    elsif ($virtualization_subtype eq "firewall") {
			$isfirewall = 1;
			$osname     = "FW-IPFW2";
			$pctype     = "pc";
			goto raw;
		    }
1100
1101
1102
1103
1104
1105
1106
1107
		    else {
			$response
			    = GeniResponse->Create(GENIRESPONSE_BADARGS,
						   undef,
				       "Malformed rspec: ".
				       "Unknown virtualization_subtype");
			goto bad;
		    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1108
1109
1110
1111
1112
1113
1114
1115
		}
		else {
		    goto raw;
		}
	    }
	    else {
	      raw:
		# Lets force to exclusive real node.
Jonathon Duerig's avatar
Jonathon Duerig committed
1116
		if (! GeniXML::SetExclusive($ref, 1)) {
1117
1118
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
1119
			"Malformed rspec: Cannot set exclusive tag to true");
1120
1121
1122
		    goto bad;
		}
		$exclusive = 1;
1123
1124
1125
1126
1127
		my $subtype = "raw-pc";
		if (GeniXML::IsVersion0($ref)) {
		    $subtype = "raw";
		}
		if (! GeniXML::SetVirtualizationSubtype($ref, $subtype)) {
1128
1129
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
1130
			"Malformed rspec: Cannot set virtualization_type to raw");
1131
1132
		    goto bad;
		}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1133
1134
1135
1136
	    }
	}
	else {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
1137
				     "Must provide a virtualization_type");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1138
1139
1140
	    goto bad;

	}
1141
1142
1143
1144
1145
1146
	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
1147
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1148
	# Allow wildcarding.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1149
	#
1150
	if (!defined($component_id) || $component_id eq "*") {
1151
1152
1153
1154
1155
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
1156
	    }
1157
1158
	    # If the node still isn't bound and doesn't have a pctype,
	    # use the user-specified one.
1159
1160
1161
1162
1163
1164
1165
1166
1167
	    if (GeniXML::IsVersion0($ref)) {
		if (! defined($node) && ! defined($pctype)) {
		    my $usertype = GeniXML::FindFirst("n:node_type", $ref);
		    if (defined($usertype)) {
			$pctype = GeniXML::GetText("type_name", $usertype);
		    }
		}
	    } else {
		my $usertype = GeniXML::FindFirst("n:hardware_type", $ref);
1168
		if (defined($usertype)) {
1169
1170
1171
1172
1173
1174
		    #
		    # Watch for pcvm type set above. If the user specified
		    # a hardware type for their VMs, then form a proper
		    # hardware specific pcvm type. 
		    #
		    my $pt = GeniXML::GetText("name", $usertype);
Leigh B Stoller's avatar
Leigh B Stoller committed
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
		    if (!defined($pt)) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad hardware_type");
			goto bad;
		    }
		    if (defined($pctype) && $pctype eq "pcvm") {
			$pctype = "${pt}-vm";
		    }
		    else {
			$pctype = $pt;
		    }
1187
1188
		}
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1189
1190
	}
	else {
1191
	    $node = GeniUtil::LookupNode($vnode_id);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1192
1193
1194
1195

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
1196
					 "Bad resource $component_id");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1197
1198
		goto bad;
	    }
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
	    #
	    # Is the node a virtual node? Must be an update to an
	    # existing sliver/ticket, since we now return the node_id
	    # of the allocated virtual node, not the physical node.
	    #
	    if ($node->isvirtnode()) {
		if (!$isupdate ||
		    !exists($namemap{$node_nickname})) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Bad resource for $node_nickname");
		    goto bad;
		}
		$node = $namemap{$node_nickname};
	    }
1214
1215
	    $pctype = $node->type()
		if (!defined($pctype));
1216
	}