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

40
41
@ISA    = qw(Exporter);
@EXPORT = qw();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42
43
44

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 GeniStitch;
59
use GeniUsage;
60
use GeniImage;
61
use libtestbed;
62
use emutil;
63
64
use EmulabConstants;
use libEmulab;
65
use Lan;
66
use User;
67
use Experiment;
68
use NodeType;
69
use Node;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70
71
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
use XML::Simple;
73
use XML::LibXML;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
use Date::Parse;
75
use POSIX qw(strftime tmpnam ceil);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
76
use Time::Local;
77
use Compress::Zlib;
78
use File::Temp qw(tempfile);
79
use MIME::Base64;
80
use Digest::SHA1 qw(sha1_hex);
81
use POSIX ":sys_wait_h";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
82
83
84
85
86
87

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

132
133
134
135
136
# For location info.
my $default_longitude = undef;
my $default_latitude  = undef;
my $default_country   = undef;

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

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
161
162
163
164
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
165
166
167
168
169
170
171
172
173
174
175
176
    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
177
178
179
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
180
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
181
182
183
184
185
186
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

187
    my $credential = GeniCredential::CheckCredential($cred);
188
189
190
    return $credential
	if (GeniResponse::IsResponse($credential));

191
    if ($type eq "node") {
192
	require Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
193
194
195
	my $node;
	
	if (defined($uuid)) {
196
	    $node= GeniUtil::LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
197
198
	}
	else {
199
	    $node= GeniUtil::LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
200
	}
201
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
202
203
204
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
205

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

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
231
232
233
234
235
236
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
237
    my $credstr   = $argref->{'credential'};
238
    my $available = $argref->{'available'} || 0;
239
    my $compress  = $argref->{'compress'} || 0;
240
    my $version   = $argref->{'rspec_version'} || undef;
241

242
    my $credential = GeniCredential::CheckCredential($credstr);
243
244
    return $credential
	if (GeniResponse::IsResponse($credential));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
245

246
247
    return DiscoverResourcesAux($available,
				$compress, $version, [$credential]);
248
249
}
# Helper function for V2.
250
sub DiscoverResourcesAux($$$$)
251
{
252
    my ($available, $compress, $version, $credentials) = @_;
253
    my $user_urn  = $ENV{'GENIRN'};
254
    $version   = "2"
255
256
257
	if (!defined($version));

    # Sanity check since this can come from client.
258
    if (! ($version eq "0.1" || $version eq "0.2" || $version eq "2"
259
260
261
	   || $version eq "3"
	   || $version eq "PG 0.1" || $version eq "PG 0.2"
	   || $version eq "PG 2")) {
262
263
264
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper version request");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
265

266
267
268
    # 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.
269
270
271
272
273
274
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
275

Leigh B. Stoller's avatar
Leigh B. Stoller committed
276
277
278
279
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
280
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
281
282
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
283
    }
284
285
286
287
288
289
290

    # 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) {
291
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
292
293
294
295
296
297
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
298
	my $user = GeniUser->Lookup($user_urn, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
299
300
301
302
303
304
305
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
    #
    # 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
325
    #
326
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
327
    #
328
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
329
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
330
331
332
333
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

334
335
336
337
338
339
    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
340
341
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
342

343
344
345
#
# Use ptopgen in xml mode to spit back an xml file. 
#
346
sub GetAdvertisement($$$$)
347
{
348
    my ($available, $pc, $version, $experiment) = @_;
349
    my $xml = undef;
350
351
    my $gotlock = 0;
    my $filename = "/var/tmp/protogeni_resources.xml";
352

353
354
355
356
357
358
359
    $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");

360
    my $invocation = "$PTOPGEN -x -g $version -r -f";
361
362
    if (defined($experiment)) {
	my $eid = $experiment->eid();
363
	my $pid = $experiment->pid();
364
	$invocation .= " -p $pid -e $eid";
365
    }
366
367
368
369
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
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
397
398
399
400
401
402
403
404
405
406
407
408
    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;
	}
    }
409
    if (open(AVAIL, "$invocation |")) {
410
	$xml = "";
411
412
413
414
415
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
    #
    # 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();
    }
437
438
439
    return $xml;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
440
#
441
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
442
#
443
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
444
445
{
    my ($argref) = @_;
446
447
448
449
450
451
452
453
454
455

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
456
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
457
    my $impotent   = $argref->{'impotent'};
458
459
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
460
461
462
463
464
465
466
    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
467

468
    if (! defined($credstr)) {
469
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
470
    }
471
    if (!defined($rspecstr)) {
472
473
	return GeniResponse->MalformedArgsResponse();
    }
474
475
476
477
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
478
    my $credential = GeniCredential::CheckCredential($credstr);
479
480
481
    return $credential
	if (GeniResponse::IsResponse($credential));

482
    if ($isupdate) {
483
	$ticket = CheckTicket($tickstr, $credential->target_urn());
484
485
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
486
    }
487
    return GetTicketAux($credential,
488
			$rspecstr, $isupdate, $impotent, 0, 1, 0, $ticket);
489
}
490

491
sub GetTicketAux($$$$$$$$$@)
492
{
493
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level, $usetracker,
494
	$ticket, $speaksfor, @morecreds) = @_;
495
    
496
497
498
499
500
501
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
502
    
503
504
    my $slice_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
505
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
506
    #
507
    # Create user from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
508
    #
509
    my $user = CreateUserFromCertificate($credential);
510
511
    return $user
	if (GeniResponse::IsResponse($user));
512
513
514

    # Bump activity. Does not matter if request fails ...
    $user->BumpActivity();
515
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
516
    #
517
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
518
    #
519
520
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
521
	if ($isupdate) {
522
	    print STDERR "Could not locate slice $slice_urn for Update\n";
523
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
524
525
526
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
527
528
	return $slice
	    if (GeniResponse::IsResponse($slice));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
529
    }
530
531
532
    $slice->SetSpeaksFor($speaksfor)
	if (defined($speaksfor));
	
533
    main::AddLogfileMetaDataFromSlice($slice);
534
    
535
    return GetTicketAuxAux($slice, $user, $rspecstr,
536
537
			   $isupdate, $impotent, $v2, $level, $usetracker,
			   $ticket, [$credential, @morecreds], $speaksfor);
538
}
539
sub GetTicketAuxAux($$$$$$$$$$$)
540
{
541
    my ($slice, $user, $rspecstr, $isupdate,
542
543
	$impotent, $v2, $level, $usetracker,
	$ticket, $credentials, $speaksfor) = @_;
544
545
546
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
547
    require OSinfo;
548
    require Image;
549
    require VirtExperiment;
550
551
552
553
554
555

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

560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
    #
    # 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");
    }

578
579
    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
580
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
581
				    "Error Parsing rspec XML");
582
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
583

584
585
586
587
588
589
    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
590
591
592
593
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
594
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
595
596
597
598
	    # Cannot get the value, say no.
	    $allow_externalusers = 0;
    }

599
600
601
602
603
604
605
606
607
608
609
    # Image tracker.
    my $use_imagetracker;
    if (!GetSiteVar('protogeni/use_imagetracker', \$use_imagetracker)) {
	# Cannot get the value, say no.
	$use_imagetracker = 0;
    }
    # But the Portal is currently the one telling us to use the tracker
    # for specific slices.
    $use_imagetracker = 1
	if ($use_imagetracker && $usetracker);

610
611
612
613
614
615
616
617
618
    #
    # Watch for sites that do not support openflow, we want to fail early.
    #
    my $no_openflow = 0;
    if (!GetSiteVar('general/no_openflow', \$no_openflow)){
	# Cannot get the value, say no.
	$no_openflow = 1;
    }

619
620
621
622
623
624
625
626
627
628
    # 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
629
    }
630
631
632

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
633
634
635
636
				    "External users temporarily denied");
    }
    
    #
637
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
638
    # ticket is redeemed, it will expire according to the rspec request.
639
640
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
641
642
    # slice credential, or the local policy max_sliver_lifetime. See
    # CreateSliceFromCertificate() in this file.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
643
    #
Jonathon Duerig's avatar
Jonathon Duerig committed
644
    my $expires = GeniXML::GetExpires($rspec);
645
    if (defined($expires)) {
646
647
	if (GeniResponse::IsResponse($expires)) {
	    return $expires;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
648
	}
649
650
	# Note "checkonly" flag; we do not actually change the slice
	# until the ticket is redeemed. 
651
	my $tmp = SetSliceExpiration($slice, $expires, 1, 0, @{ $credentials });
652
653
	if (GeniResponse::IsResponse($tmp)) {
	    return $tmp;
654
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
655
    }
656
657
658
659
660
661
662

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

693
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
694
    # For now, there can be only a single toplevel aggregate per slice.
695
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
696
    #
697
    my $aggregate = GeniAggregate->SliceAggregate($slice);
698
699
700
701
702
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
703
704
	}
    }
705
    elsif ($v2 && $level > 0 && !defined($ticket) && !defined($aggregate)) {
706
707
708
709
	print STDERR "No aggregate for $slice in version two API\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
710

711
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
712
    # We need this now so we can form a virtual topo.
713
    #
714
715
716
717
718
719
720
721
722
723
724
    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
725
726
727
728
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
729
730
731
732
733

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

    #
    # Allow user to control the multiplex factor. Note that ptopgen
    # will not allow the mfactor to be more then what we set as the
    # max for the node, but in general we set it low here.
    #
    $virtexperiment->multiplex_factor(GeniXML::MultiplexFactor($rspec) || 10);
761
762
763
764
765
    #
    # The packing strategy is sorta independent; the user can specify either
    # pack or balance (load balance).
    #
    my $packing_option = GeniXML::PackingStrategy($rspec);
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

790
791
792
    #
    # Look for toplevel address pools
    #
793
794
795
796
797
798
799
    if (Node::HaveExperimentNodes()) {
	my $address_pools = GeniXML::GetAddressPools($rspec);
	foreach my $pool (@{ $address_pools }) {
	    if (! defined($pool->{'cmurn'}) ||
		$pool->{'cmurn'} eq $ENV{'MYURN'})
	    {
		if ($pool->{'type'} ne "any") {
800
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
801
802
803
804
805
		     "Only public address pools of type any are supported");
		    goto bad;
		}
		print STDERR 'DEBUG: Adding row to virt_address_allocation';
		$virtexperiment->NewTableRow("virt_address_allocation",
806
807
808
809
					 {"pool_id" => $pool->{'client_id'},
					  "count" => $pool->{'count'},
					  "restriction" => $pool->{'type'},
					  "version" => "ipv4" });
810
	    }
811
812
813
	}
    }

814
815
816
817
818
819
820
821
822
823
824
825
    #
    # Look for toplevel elabinelab section.
    #
    my $elabinelab_settings = GeniXML::GetElabInElabSettings($rspec);
    if (defined($elabinelab_settings)) {
	$virtexperiment->elab_in_elab(1);
	if (exists($elabinelab_settings->{'singlenet'})) {
	    $virtexperiment->elabinelab_singlenet(1);
	}
	if (exists($elabinelab_settings->{'xen'})) {
	    $virtexperiment->multiplex_factor(2);
	}
826
827
828
    }
    if ($PROTOGENI_NONFSMOUNTS) {
	$virtexperiment->nonfsmounts(1);
829
830
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
831
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
832
833
    # 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
834
835
    # cannot be granted.
    #
836
837
838
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
839
    my %iface2node = ();
840
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
841
    my %nodemap  = ();
842
    my %bridgemap= ();
843
    my @nodeids  = ();
844
    my %lannodes = ();
845
    # For stitching, keep track of external nodes and links.
846
847
848
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
849
    my %external_lanrefs  = ();
850

851
852
853
    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();
    
854
855
856
857
858
859
860
    #
    # 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
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
	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;
	}
878
879
880
881
882
883
884
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
885
	
886
	foreach my $ref (GeniXML::FindNodes("n:node",
887
					    $oldrspec)->get_nodelist()) {
888
	    # Let remote nodes pass through.
889
	    next
890
		if (!GeniXML::IsLocalNode($ref));
891

892
893
	    # Skip lan nodes; they are fake.
	    next
894
		if (GeniXML::IsLanNode($ref));
895

896
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
897
	    my $colocate      = GeniXML::GetColocate($ref);
898
	    my $component_id  = GeniXML::GetNodeId($ref);
899
900
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
901
902
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
903
				 "Bad resource $component_id in ticket");
904
905
		goto bad;
	    }
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
	    #
	    # 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;
	    }
921
922
923
924
925
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
926

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

929
930
    my %nodeexistsmap = ();

931
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
932
	my $component_id  = GeniXML::GetNodeId($ref);
933
	my $vnode_id      = GeniXML::GetVnodeId($ref);
934
	my $manager_id    = GeniXML::GetManagerId($ref);
935
	my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
936
937
938
939
	my $colocate      = GeniXML::GetColocate($ref);
	my $subnode_of    = GeniXML::GetSubnodeOf($ref);
	my $virtualization_type = GeniXML::GetVirtualizationType($ref);
	
940
	my $virtualization_subtype
Jonathon Duerig's avatar
Jonathon Duerig committed
941
942
                          = GeniXML::GetVirtualizationSubtype($ref);
	my $exclusive     = GeniXML::GetExclusive($ref);
943
	my $tarfiles      = GeniXML::GetTarball($ref);
944
	my $pctype;
945
	my ($osname, $osinfo);
946
	my $parent_osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
947
	my $node;
948
949
	my $isbridge    = 0;
	my $isfirewall  = 0;
Leigh B Stoller's avatar
Leigh B Stoller committed
950
	my $xensettings;
951
	my $fwsettings;
952
	
953
	if (exists($nodeexistsmap{lc($node_nickname)})) {
954
955
956
957
958
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate node $node_nickname");
	    goto bad;
	}
959
	$nodeexistsmap{lc($node_nickname)} = 1;
960

961
962
963
964
965
	# 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);
966
967
968
969
970
971
972
	    if (exists($iface2node{$virtual_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Duplicate interface $virtual_id on ".
					 "node $node_nickname");
		goto bad;
	    }
973
974
975
	    $iface2node{$virtual_id} = $node_nickname;
	}

976
	# Let remote nodes pass through.
977
978
979
980
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}
981

982
	#
983
984
985
986
987
	#
	# 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. 
	#
988
	if (GeniXML::IsLanNode($ref)) {
989
990
991
992
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

993
994
995
996
997
998
999
1000
	#
	# Check for total hostname length > 63 characters. This
	# breaks a lot of clients. Do this until we have a plan
	# for dealing with it on the clients. Why 63 instead of 64?
	# Cause of a bug in the event library code, that is now fixed,
	# but will not make it out to all images for a while. 
	#
	my $fullhostname = $node_nickname . ".${eid}.${pid}.${OURDOMAIN}";
For faster browsing, not all history is shown. View entire blame