GeniCM.pm.in 182 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -wT
#
Leigh B Stoller's avatar
Leigh B Stoller committed
3
# Copyright (c) 2008-2012 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
84
85

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
    #
    # 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
312
    #
313
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
314
    #
315
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
316
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
317
318
319
320
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

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

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

340
341
342
343
344
345
346
    $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");

347
    my $invocation = "$PTOPGEN -x -g $version -r";
348
349
350
351
    if (defined($experiment)) {
	my $eid = $experiment->eid();
	$invocation .= " -e $eid";
    }
352
353
354
355
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
356
357
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
    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;
	}
    }
395
    if (open(AVAIL, "$invocation |")) {
396
	$xml = "";
397
398
399
400
401
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
    #
    # 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();
    }
423
424
425
    return $xml;
}

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

    return GetTicket($argref, 1);
}

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

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

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

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

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

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

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

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

565
566
567
568
569
570
    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
571
572
573
574
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
575
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
576
577
578
579
580
581
582
583
584
585
586
587
588
589
	    # 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
590
    }
591
592
593

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

	# 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
640
	my $diff = $when - time();
641
642
643
644
645
646
	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
647
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
648
649
			"expiration is greater then the maximum number ".
			"of minutes " . (60 * 24 * $max_sliver_lifetime));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
650
	}
651
652
653
654
655
656

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

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

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

719
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
720
    # We need this now so we can form a virtual topo.
721
    #
722
723
724
725
726
727
728
729
730
731
732
    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
733
734
735
736
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
737
738
739
740
741

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

764
765
766
767
768
769
770
771
772
773
    #
    # 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()) {
774
	$virtexperiment->NewTableRow("virt_vtypes",
775
776
777
778
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
779
    }
780

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

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

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

848
849
	    # Skip lan nodes; they are fake.
	    next
850
		if (GeniXML::IsLanNode($ref));
851

852
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
853
	    my $colocate      = GeniXML::GetColocate($ref);
854
	    my $component_id  = GeniXML::GetNodeId($ref);
855
856
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
857
858
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
859
				 "Bad resource $component_id in ticket");
860
861
		goto bad;
	    }
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
	    #
	    # 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;
	    }
877
878
879
880
881
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
882

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

885
886
    my %nodeexistsmap = ();

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

915
916
917
918
919
	# 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);
920
921
922
923
924
925
926
	    if (exists($iface2node{$virtual_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Duplicate interface $virtual_id on ".
					 "node $node_nickname");
		goto bad;
	    }
927
928
929
	    $iface2node{$virtual_id} = $node_nickname;
	}

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

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

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

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

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

	}
1138
1139
1140
1141
1142
1143
	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
1144
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1145
	# Allow wildcarding.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1146
	#
1147
	if (!defined($component_id) || $component_id eq "*") {
1148
1149
1150
1151
1152
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
1153
	    }
1154
1155
	    # If the node still isn't bound and doesn't have a pctype,
	    # use the user-specified one.
1156
1157
1158
1159
1160
1161
1162
1163
1164
	    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);
1165
		if (defined($usertype)) {
1166
1167
1168
1169
1170
1171
		    #
		    # 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
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
		    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;
		    }
1184
1185
		}
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1186
1187
	}
	else {
1188
	    $node = GeniUtil::LookupNode($vnode_id);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1189
1190
1191
1192

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
1193
					 "Bad resource $component_id");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1194
1195
		goto bad;
	    }
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
	    #
	    # 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};
	    }
1211
1212
	    $pctype = $node->type()
		if (!defined($pctype));
1213
	}
1214

1215
	#
1216
	# If no osname, check for protogeni default osname
1217
	#<