GeniCM.pm.in 237 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2008-2017 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";
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 $RFLINKS	   = "$TB/bin/rflinks";
128
my $FWNAME	   = "fw";
129
my $API_VERSION    = 1;
130
131
my $PROTOGENI_LOCALUSER   = @PROTOGENI_LOCALUSER@;
my $PROTOGENI_NONFSMOUNTS = @PROTOGENI_NONFSMOUNTS@;
132

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    return GetTicket($argref, 1);
}

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

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

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

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

    # Bump activity. Does not matter if request fails ...
    $user->BumpActivity();
516
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
517
    #
518
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
519
    #
520
521
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
522
	if ($isupdate) {
523
	    print STDERR "Could not locate slice $slice_urn for Update\n";
524
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
525
526
527
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
528
529
	return $slice
	    if (GeniResponse::IsResponse($slice));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
530
    }
531
532
533
    $slice->SetSpeaksFor($speaksfor)
	if (defined($speaksfor));
	
534
    main::AddLogfileMetaDataFromSlice($slice);
535
    
536
    return GetTicketAuxAux($slice, $user, $rspecstr,
537
538
			   $isupdate, $impotent, $v2, $level, $usetracker,
			   $ticket, [$credential, @morecreds], $speaksfor);
539
}
540
sub GetTicketAuxAux($$$$$$$$$$$)
541
{
542
    my ($slice, $user, $rspecstr, $isupdate,
543
544
	$impotent, $v2, $level, $usetracker,
	$ticket, $credentials, $speaksfor) = @_;
545
546
547
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
548
    require OSImage;
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
    #
    # Watch for sites that do not support openflow, we want to fail early.
    #
    my $no_openflow = 0;
614
    my $ignore_openflow = 0;
615
616
617
618
    if (!GetSiteVar('general/no_openflow', \$no_openflow)){
	# Cannot get the value, say no.
	$no_openflow = 1;
    }
619
620
621
622
    if ($no_openflow =~ /ignore/) {
	$no_openflow = 1;
	$ignore_openflow = 1;
    }
623

624
625
626
627
628
629
630
631
632
633
    # 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
634
    }
635
636
637

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

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

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

716
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
717
    # We need this now so we can form a virtual topo.
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;
    }
725
726
727
728
729
730
731
732
733
734
735
    #
    # Mark the expires slot in the experiment, for admission control
    # during the mapper run. 
    #
    if ($slice_experiment->SetExpiration(defined($expires) ? $expires :
					 $slice->expires())) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "set experiment expiration");
	print STDERR "Could not set experiment expiration\n";
	goto bad;
    }
736
737
738
739
740
    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
741
742
743
744
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
745
746
747
748
749

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

    #
    # Allow user to control the multiplex factor. Note that ptopgen
    # will not allow the mfactor to be more then what we set as the
774
775
776
777
778
779
780
781
782
783
784
785
786
787
    # max for the node, but in general we set it low here. Also note
    # that to support Emulab Classic NS file conversion, zero means to
    # not change it.
    #
    my $mfactor = GeniXML::MultiplexFactor($rspec);
    if (defined($mfactor)) {
	if ($mfactor != 0) {
	    $virtexperiment->multiplex_factor($mfactor);
	}
    }
    else {
	# Odd geni default dating back to the beginning of time.
	$virtexperiment->multiplex_factor(10);
    }
788
789
790
791
792
    #
    # The packing strategy is sorta independent; the user can specify either
    # pack or balance (load balance).
    #
    my $packing_option = GeniXML::PackingStrategy($rspec);
793

794
    #
795
    # User can turn off routing.
796
    #
797
798
799
800
801
802
803
804
805
806
807
808
    my $routertype = GeniXML::RoutingStyle($rspec);
    if (!defined($routertype)) {
	$routertype = "static-ddijk";
    }
    elsif ($routertype eq "static") {
	$routertype = "static-ddijk";
    }
    elsif ($routertype ne "none") {
	$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad routing style: $routertype");
	goto bad;
    }
809
    
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
    #
    # User can set the delay image. 
    #
    if (defined(GeniXML::DelayImage($rspec))) {
	my $delayurn = GeniXML::DelayImage($rspec);
	
	if (!GeniHRN::IsValid($delayurn)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid URN: $delayurn");
	    goto bad;
	}
	my $hrn = GeniHRN->new($delayurn);
	my (undef,$ospid,$os,$vers) = $hrn->ParseImage();
	if ($hrn->type() ne "image" || !defined($ospid) || !defined($os)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Malformed image URN: $delayurn");
	    goto bad;
	}
	my $delayname = $os;
	$delayname = "${ospid}/" . $delayname
	    if (defined($ospid));
	$delayname .= ":${vers}"
	    if (defined($vers));
	
	$virtexperiment->delay_osname($delayname);
    }
836

837
838
839
840
841
842
843
844
845
846
    #
    # 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()) {
847
	$virtexperiment->NewTableRow("virt_vtypes",
848
849
850
851
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
852
    }
853

854
855
856
857
858
    # Need to move this someplace else; the parser adds a bunch.
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "ns",
				  "objecttype" => "6"});
859
860
861
862
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "linktest",
				  "objecttype" => "7"});
863

864
865
866
    #
    # Look for toplevel address pools
    #
867
868
869
870
871
872
873
    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") {
874
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
875
876
877
878
879
		     "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",
880
881
882
883
					 {"pool_id" => $pool->{'client_id'},
					  "count" => $pool->{'count'},
					  "restriction" => $pool->{'type'},
					  "version" => "ipv4" });
884
	    }
885
886
887
	}
    }

888
889
890
891
892
893
894
895
896
897
898
899
    #
    # 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);
	}
900
    }
901
902
903
904
    #
    # Note that we set the mounts to "genidefault" when we create the
    # container experiment. So this overrides.
    #
905
906
    if ($PROTOGENI_NONFSMOUNTS) {
	$virtexperiment->nonfsmounts(1);
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
	# This is the new way of doing things.
	$virtexperiment->nfsmounts("none");
    }
    elsif (GeniXML::FromEmulabPortal($rspec) && $PROTOGENI_LOCALUSER) {
	#
	# By not setting, we get standard emulab mounts which include
	# /users. Not sure if I want to explictly set this.
	#
	# But we do not let anyone do this, at the moment only the local
	# SA can do that, which means the authority that contacted us
	# must be our SA. Not even users from our SA can specify this.
	#
	my $hrn = GeniHRN->new($ENV{"GENIURN"});
	if (defined($hrn) &&
	    $hrn->domain() eq $OURDOMAIN && $hrn->IsSA()) {
	    $virtexperiment->nfsmounts("emulabdefault");
	}
924
925
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
926
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
927
928
    # 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
929
930
    # cannot be granted.
    #
931
932
933
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
934
    my %iface2node = ();
935
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
936
    my %nodemap  = ();
937
    my %bridgemap= ();
938
    my @nodeids  = ();
939
    my %lannodes = ();
940
    my %allnodes = ();
941
942
    # Extra nodes (like XEN vhosts).
    my %internal_nodemap  = ();
943
    # For stitching, keep track of external nodes and links.
944
945
946
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
947
    my %external_lanrefs  = ();
Leigh B Stoller's avatar
Leigh B Stoller committed
948
    my $routable_ip_count = 0;
949
    my $sync_server = ($isupdate ? $slice_experiment->sync_server() : undef);
950

951
952
    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977

    #
    # Find all the node client ids, so we can support binding VMs to other
    # nodes in the topology. We could enforce that the rspec has to put
    # those nodes first, but that would be annoying to users. And me.
    #
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
	# Let remote nodes pass through.
	next
	    if (!GeniXML::IsLocalNode($ref));

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

	my $node_nickname = GeniXML::GetVirtualId($ref);

	# Might as well do a duplicate check while we are here.
	if (exists($allnodes{lc($node_nickname)})) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Duplicate node $node_nickname");
	    goto bad;
	}
	$allnodes{lc($node_nickname)} = 1;
    }
978
    
979
980
981
982
983
984
985
    #
    # 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
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
	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);
For faster browsing, not all history is shown. View entire blame