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

#
# The server side of the CM interface on remote sites. Also communicates
# with the GMC interface at Geni Central as a client.
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

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

use GeniDB;
use Genixmlrpc;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
22
23
use GeniResponse;
use GeniTicket;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
24
use GeniCredential;
25
use GeniCertificate;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
26
use GeniSlice;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
27
use GeniAggregate;
28
use GeniAuthority;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
use GeniSliver;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
30
use GeniUser;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
31
use GeniRegistry;
32
use GeniUtil;
33
use GeniHRN;
34
use GeniXML;
35
use GeniUsage;
36
use libtestbed;
37
use emutil;
38
39
use EmulabConstants;
use libEmulab;
40
use Lan;
41
use Experiment;
42
use NodeType;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
43
44
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
45
use XML::Simple;
46
use XML::LibXML;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
use Date::Parse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
48
use POSIX qw(strftime tmpnam);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
49
use Time::Local;
50
use Compress::Zlib;
51
use File::Temp qw(tempfile);
52
use MIME::Base64;
53
use Digest::SHA1 qw(sha1_hex);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
54
55
56
57
58
59
60
61

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
62
my $MAINSITE       = @TBMAINSITE@;
63
my $ELABINELAB     = @ELABINELAB@;
64
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
65
my $PROTOUSER 	   = "elabman";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
66
my $CREATEEXPT     = "$TB/bin/batchexp";
67
my $ENDEXP         = "$TB/bin/endexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
68
my $NALLOC	   = "$TB/bin/nalloc";
69
my $NFREE	   = "$TB/bin/nfree";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70
my $AVAIL	   = "$TB/sbin/avail";
71
my $PTOPGEN	   = "$TB/libexec/ptopgen";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
73
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
75
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
76
my $EXPORTS_SETUP  = "$TB/sbin/exports_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
77
78
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
79
my $IPASSIGN       = "$TB/libexec/ipassign_wrapper";
80
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
81
82
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
83
my $SNMPIT         = "$TB/bin/snmpit_test";
84
my $RESERVEVLANS   = "$TB/sbin/protogeni/reservevlans";
85
my $NEWGROUP       = "$TB/bin/newgroup";
86
87
my $NEWPROJECT     = "$TB/sbin/newproj";
my $MAKEPROJECT    = "$TB/sbin/mkproj";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
88
my $PRERENDER      = "$TB/libexec/vis/prerender";
89
90
my $SUDO           = "/usr/local/bin/sudo";
my $WAP            = "$TB/sbin/withadminprivs";
91
my $XMLLINT	   = "/usr/local/bin/xmllint";
92
my $ADDAUTHORITY   = "$TB/sbin/protogeni/addauthority";
93
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
94
my $TARINSTALL     = "/usr/local/bin/install-tarfile";
95
my $FWNAME	   = "fw";
96
my $API_VERSION    = 1;
97
my $USELOCALPROJ   = 0;
98
99
100
101
102
103
104
105
106
107
108

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

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

149
150
151
152
    my $credential = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

153
    if ($type eq "node") {
154
	require Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
155
156
157
	my $node;
	
	if (defined($uuid)) {
158
	    $node= GeniUtil::LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
159
160
	}
	else {
161
	    $node= GeniUtil::LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
162
	}
163
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
164
165
166
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
167

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

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
193
194
195
196
197
198
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
199
    my $credstr   = $argref->{'credential'};
200
    my $available = $argref->{'available'} || 0;
201
    my $compress  = $argref->{'compress'} || 0;
202
    my $version   = $argref->{'rspec_version'} || undef;
203
204
205
206

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

208
209
    return DiscoverResourcesAux($available,
				$compress, $version, [$credential]);
210
211
}
# Helper function for V2.
212
sub DiscoverResourcesAux($$$$)
213
{
214
    my ($available, $compress, $version, $credentials) = @_;
215
    my $user_urn  = $ENV{'GENIRN'};
216
    $version   = "2"
217
218
219
	if (!defined($version));

    # Sanity check since this can come from client.
220
    if (! ($version eq "0.1" || $version eq "0.2" || $version eq "2"
221
222
223
	   || $version eq "3"
	   || $version eq "PG 0.1" || $version eq "PG 0.2"
	   || $version eq "PG 2")) {
224
225
226
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper version request");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
227

228
229
230
    # 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.
231
232
233
234
235
236
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
237

Leigh B. Stoller's avatar
Leigh B. Stoller committed
238
239
240
241
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
242
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
243
244
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
245
    }
246
247
248
249
250
251
252

    # 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) {
253
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
254
255
256
257
258
259
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
260
	my $user = GeniUser->Lookup($user_urn, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
261
262
263
264
265
266
267
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
    #
    # 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
287
    #
288
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
289
    #
290
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
291
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
292
293
294
295
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

296
297
298
299
300
301
    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
302
303
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
304

305
306
307
#
# Use ptopgen in xml mode to spit back an xml file. 
#
308
sub GetAdvertisement($$$$)
309
{
310
    my ($available, $pc, $version, $experiment) = @_;
311
    my $xml = undef;
312
313
    my $gotlock = 0;
    my $filename = "/var/tmp/protogeni_resources.xml";
314

315
316
317
318
319
320
321
    $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");

322
    my $invocation = "$PTOPGEN -x -g $version -r -p GeniSlices";
323
324
325
326
    if (defined($experiment)) {
	my $eid = $experiment->eid();
	$invocation .= " -e $eid";
    }
327
328
329
330
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    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;
	}
    }
370
    if (open(AVAIL, "$invocation |")) {
371
	$xml = "";
372
373
374
375
376
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
    #
    # 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();
    }
398
399
400
    return $xml;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
401
#
402
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
403
#
404
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
405
406
{
    my ($argref) = @_;
407
408
409
410
411
412
413
414
415
416

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
417
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
418
    my $impotent   = $argref->{'impotent'};
419
420
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
421
422
423
424
425
426
427
    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
428

429
    if (! defined($credstr)) {
430
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
431
    }
432
    if (!defined($rspecstr)) {
433
434
	return GeniResponse->MalformedArgsResponse();
    }
435
436
437
438
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
439
440
441
442
    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

443
    if ($isupdate) {
444
445
446
	$ticket = CheckTicket($tickstr);
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
447
    }
448
    return GetTicketAux($credential,
449
			$rspecstr, $isupdate, $impotent, 0, 1, $ticket);
450
}
451

452
sub GetTicketAux($$$$$$$)
453
{
454
455
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level,
	$ticket) = @_;
456
    
457
458
459
460
461
462
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
463
    
464
465
    my $slice_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
466
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
467
    #
468
    # Create user from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
469
    #
470
    my $user = CreateUserFromCertificate($credential);
471
472
    return $user
	if (GeniResponse::IsResponse($user));
473
474
475

    # Bump activity. Does not matter if request fails ...
    $user->BumpActivity();
476
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
477
    #
478
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
479
    #
480
481
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
482
	if ($isupdate) {
483
	    print STDERR "Could not locate slice $slice_urn for Update\n";
484
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
485
486
487
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
488
489
	return $slice
	    if (GeniResponse::IsResponse($slice));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
490
    }
491
    
492
    return GetTicketAuxAux($slice, $user, $rspecstr,
493
494
			   $isupdate, $impotent, $v2, $level, $ticket,
			   [$credential]);
495
}
496
sub GetTicketAuxAux($$$$$$$$$)
497
{
498
499
    my ($slice, $user, $rspecstr, 
        $isupdate, $impotent, $v2, $level, $ticket, $credentials) = @_;
500
501
502
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
503
504
    require OSinfo;
    require VirtExperiment;
505
506
507
508
509
510

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

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
    #
    # 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");
    }

533
534
    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
535
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
536
				    "Error Parsing rspec XML");
537
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
538

539
540
541
542
543
544
    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
545
546
547
548
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
549
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
550
551
552
553
554
555
556
557
558
559
560
561
562
563
	    # 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
564
    }
565
566
567

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
568
569
570
571
				    "External users temporarily denied");
    }
    
    #
572
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
573
    # ticket is redeemed, it will expire according to the rspec request.
574
575
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
576
577
    # slice credential, or the local policy max_sliver_lifetime. See
    # CreateSliceFromCertificate() in this file.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
578
    #
Jonathon Duerig's avatar
Jonathon Duerig committed
579
    my $expires = GeniXML::GetExpires($rspec);
580
    if (defined($expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
581
582
583
584
585
586
587
588
589
590
591
592
	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");
	}
	
	#
593
	# Do we need a policy limit?
Leigh B Stoller's avatar
Leigh B Stoller committed
594
595
596
597
598
	# A sitevar controls the sliver lifetime.
	#
	my $max_sliver_lifetime = 0;
	if (!GetSiteVar('protogeni/max_sliver_lifetime',
			\$max_sliver_lifetime)){
599
600
	    # Cannot get the value, default it to 90 days.
	    $max_sliver_lifetime = 90;
Leigh B Stoller's avatar
Leigh B Stoller committed
601
602
603
604
605
606
607
608
609
610
611
612
613
	}

	# 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
614
	my $diff = $when - time();
615
616
617
618
619
620
	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
621
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
622
623
			"expiration is greater then the maximum number ".
			"of minutes " . (60 * 24 * $max_sliver_lifetime));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
624
	}
625
626
627
628
629
630

	#
	# Must be before the slice expires.
	#
	my $slice_expires = $slice->expires();
	if (defined($slice_expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
631
	    $slice_expires = str2time($slice_expires);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
632
	    if ($when > $slice_expires) {
633
634
635
636
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "valid_until is past slice expiration");
	    }
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
637
    }
638
639
640
641
642
643
644

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
645
646
647
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
648
649
650
651
652
653
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
654
655
656
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
657
    }
658
659
660
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
661
662
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
663
664
665
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
666
667
668
669
670
671
672
673
    # 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
674

675
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
676
    # For now, there can be only a single toplevel aggregate per slice.
677
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
678
    #
679
    my $aggregate = GeniAggregate->SliceAggregate($slice);
680
681
682
683
684
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
685
686
	}
    }
687
688
689
690
691
    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;
    }
692

693
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
694
    # We need this now so we can form a virtual topo.
695
    #
696
697
698
699
700
701
702
703
704
705
706
    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
707
708
709
710
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
711
712
713
714
715

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
716
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
717
718
    if (defined($generated_by) &&
	$generated_by eq "libvtop") {
719
720
721
722
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
723
724
725
726
727
728
729
730
731
732
733
734
735
    
    #
    # 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);
736
    $virtexperiment->multiplex_factor(10);
737

738
739
740
741
742
743
744
745
746
747
    #
    # 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()) {
748
	$virtexperiment->NewTableRow("virt_vtypes",
749
750
751
752
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
753
    }
754

755
756
757
758
759
    # Need to move this someplace else; the parser adds a bunch.
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "ns",
				  "objecttype" => "6"});
760

Leigh B. Stoller's avatar
Leigh B. Stoller committed
761
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
762
763
    # 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
764
765
    # cannot be granted.
    #
766
767
768
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
769
    my %iface2node = ();
770
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
771
    my %nodemap  = ();
772
    my %bridgemap= ();
773
    my @nodeids  = ();
774
    my %lannodes = ();
775
    # For stitching, keep track of external nodes and links.
776
777
778
779
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
    my %stitching_paths   = ();
780
781
782
783
784
785
786
787

    #
    # 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
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
	$slice_experiment->ClearBackupState();
	if ($slice_experiment->BackupVirtualState()) {
	    print STDERR "Could not backup virtual state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	if ($slice_experiment->RemoveVirtualState()) {
	    print STDERR "Could not remove virtual state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	$restorevirt = 1;

	if ($slice_experiment->BackupPhysicalState()) {
	    print STDERR "Could not backup physical state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
806
807
808
809
810
811
812
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
813
	
814
	foreach my $ref (GeniXML::FindNodes("n:node",
815
					    $oldrspec)->get_nodelist()) {
816
	    # Let remote nodes pass through.
817
	    next
818
		if (!GeniXML::IsLocalNode($ref));
819

820
821
	    # Skip lan nodes; they are fake.
	    next
822
		if (GeniXML::IsLanNode($ref));
823

824
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
825
	    my $colocate      = GeniXML::GetColocate($ref);
826
	    my $component_id  = GeniXML::GetNodeId($ref);
827
828
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
829
830
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
831
				 "Bad resource $component_id in ticket");
832
833
		goto bad;
	    }
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
	    #
	    # 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;
	    }
849
850
851
852
853
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
854

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

857
858
    my %nodeexistsmap = ();

859
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
860
	my $component_id  = GeniXML::GetNodeId($ref);
861
	my $vnode_id      = GeniXML::GetVnodeId($ref);
862
	my $manager_id    = GeniXML::GetManagerId($ref);
863
	my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
864
865
866
867
	my $colocate      = GeniXML::GetColocate($ref);
	my $subnode_of    = GeniXML::GetSubnodeOf($ref);
	my $virtualization_type = GeniXML::GetVirtualizationType($ref);
	
868
	my $virtualization_subtype
Jonathon Duerig's avatar
Jonathon Duerig committed
869
870
                          = GeniXML::GetVirtualizationSubtype($ref);
	my $exclusive     = GeniXML::GetExclusive($ref);
871
	my $tarfiles      = GeniXML::GetTarball($ref);
872
	my $pctype;
873
	my ($osname, $osinfo);
874
	my $parent_osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
875
	my $node;
876
877
878
	my $isbridge    = 0;
	my $isfirewall  = 0;
	
879
880
881
882
883
884
885
886
	if (exists($nodeexistsmap{$node_nickname})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate node $node_nickname");
	    goto bad;
	}
	$nodeexistsmap{$node_nickname} = 1;

887
888
889
890
891
	# 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);
892
893
894
895
896
897
898
	    if (exists($iface2node{$virtual_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Duplicate interface $virtual_id on ".
					 "node $node_nickname");
		goto bad;
	    }
899
900
901
	    $iface2node{$virtual_id} = $node_nickname;
	}

902
	# Let remote nodes pass through.
903
904
905
906
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}
907

908
	#
909
910
911
912
913
	#
	# 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. 
	#
914
	if (GeniXML::IsLanNode($ref)) {
915
916
917
918
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

919
920
921
	#
	# Check for disk_image request. Specified as a URN. 
	#
922
	my $diskref = GeniXML::GetDiskImage($ref);
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
	if (defined($diskref)) {
	    my $dname = GeniXML::GetText("name", $diskref);

	    if (defined($dname)) {
		if (! GeniHRN::IsValid($dname)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
		my ($auth,$type,$id) = GeniHRN::Parse($dname);
		my ($ospid,$os) = ($id =~ m{(.*)//(.*)});
		if ($type ne "image" || !defined($ospid) || !defined($os)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
941
		$osinfo = OSinfo->Lookup($ospid, $os);
942
		if (!defined($osinfo)) {
943
944
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
945
					     "Unknown image URN: $dname");
946
947
		    goto bad;
		}
948
949
950
951
952
953
		#
		# The OS must be in the current project, or it must
		# be global (okay, shared).
		#
		if (! ($osinfo->shared() ||
		       $osinfo->pid() eq $slice_experiment->pid())) {
954
955
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
956
				 "Insufficient permission to use $osinfo");
957
958
		    goto bad;
		}
959
		
960
961
962
		#
		# This is only going to be used in raw mode. 
		#
963
		$osname = "$ospid/$os";
964
965
966
	    }
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
967
968
969
	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
970
971
		    $pctype = "pcvm";
		    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
972
973
974
975
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
976
977
978
979
980
981
982
983
984
985
986
			# 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";
			    }
			}
			else {
			    $osname = "OPENVZ-STD";
			}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
987
		    }
988
989
990
991
		    elsif ($virtualization_subtype eq "emulab-spp") {
			$osname = "SPPVM-FAKE";
			$pctype = "sppvm";
			# Lets force to shared node.
Jonathon Duerig's avatar
Jonathon Duerig committed
992
			if (! GeniXML::SetExclusive($ref, 0)) {
993
994
995
			    $response
				= GeniResponse->Create(GENIRESPONSE_BADARGS,
						       undef,
996
997
				       "Malformed rspec: ".
				       "Cannot set exclusive tag to false");
998
999
1000
			    goto bad;
			}
			$exclusive = 0;