GeniCM.pm.in 135 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-2011 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 qw(SENDMAIL);
37
use emutil;
38
39
use EmulabConstants;
use libEmulab;
40
use Lan;
41
use Experiment;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42
43
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
44
use XML::Simple;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
45
use Date::Parse;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
46
use POSIX qw(strftime tmpnam);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
use Time::Local;
48
use Compress::Zlib;
49
use File::Temp qw(tempfile);
50
use MIME::Base64;
51
use Digest::SHA1 qw(sha1_hex);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52
53
54
55
56
57
58
59

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
60
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
61
my $CREATEEXPT     = "$TB/bin/batchexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
62
my $ENDEXPT        = "$TB/bin/endexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
63
my $NALLOC	   = "$TB/bin/nalloc";
64
my $NFREE	   = "$TB/bin/nfree";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
65
my $AVAIL	   = "$TB/sbin/avail";
66
my $PTOPGEN	   = "$TB/libexec/ptopgen";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
67
68
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
69
70
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
71
my $EXPORTS_SETUP  = "$TB/sbin/exports_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
73
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
74
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
75
76
77
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
my $SNMPIT         = "$TB/bin/snmpit";
78
my $RESERVEVLANS   = "$TB/sbin/protogeni/reservevlans";
79
my $NEWGROUP       = "$TB/bin/newgroup";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
80
my $PRERENDER      = "$TB/libexec/vis/prerender";
81
my $XMLLINT	   = "/usr/local/bin/xmllint";
82
my $ADDAUTHORITY   = "$TB/sbin/protogeni/addauthority";
83
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
84
my $API_VERSION    = 1;
85
86
87
88
89
90
91
92
93
94
95

#
# 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
96
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
97
# Respond to a Resolve request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
98
99
100
101
102
103
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
104
105
    my $type       = lc( $argref->{'type'} );
    my $hrn        = $argref->{'hrn'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
106
107
108
109

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
110
111
112
113
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
114
115
116
117
118
119
120
121
122
123
124
125
    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
126
127
128
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
129
    if (! defined($uuid) && !defined( $hrn ) ) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
130
131
132
133
134
135
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

136
137
138
139
    my $credential = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

140
    if ($type eq "node") {
141
	require Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
142
143
144
	my $node;
	
	if (defined($uuid)) {
145
	    $node= GeniUtil::LookupNode($uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
146
147
	}
	else {
148
	    $node= GeniUtil::LookupNode($hrn);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
149
	}
150
	if (! defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
151
152
153
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
154

155
	my $rspec = GetAdvertisement(0, $node->node_id(), "0.1", undef);
156
157
158
159
	if (! defined($rspec)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not start avail");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
160
161
	
	# Return a blob.
162
	my $blob = { "hrn"          => "${PGENIDOMAIN}." . $node->node_id(),
Leigh B. Stoller's avatar
Leigh B. Stoller committed
163
		     "uuid"         => $node->uuid(),
164
		     "role"	    => $node->role(),
165
166
		     "hostname"     =>
			 GeniUtil::FindHostname($node->node_id()),
167
168
		     "physctrl"     => 
			 Interface->LookupControl( $node->phys_nodeid() )->IP(),
169
170
		     "urn"          => GeniHRN::Generate( $OURDOMAIN,
							  "node",
171
172
							  $node->node_id() ),
		     "rspec"        => $rspec
Leigh B. Stoller's avatar
Leigh B. Stoller committed
173
174
175
176
177
178
179
		   };

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
180
181
182
183
184
185
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
186
    my $credstr   = $argref->{'credential'};
187
    my $available = $argref->{'available'} || 0;
188
    my $compress  = $argref->{'compress'} || 0;
189
    my $version   = $argref->{'rspec_version'} || undef;
190
191
192
193

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

195
196
    return DiscoverResourcesAux($available,
				$compress, $version, [$credential]);
197
198
}
# Helper function for V2.
199
sub DiscoverResourcesAux($$$$)
200
{
201
    my ($available, $compress, $version, $credentials) = @_;
202
    my $user_urn  = $ENV{'GENIRN'};
203
204
205
206
    $version   = "0.2"
	if (!defined($version));

    # Sanity check since this can come from client.
207
208
209
    if (! ($version eq "0.1" || $version eq "0.2" || $version eq "2"
	|| $version eq "PG 0.1" || $version eq "PG 0.2"
	|| $version eq "PG 2")) {
210
211
212
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper version request");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
213

214
215
216
    # 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.
217
218
219
220
221
222
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
223

Leigh B. Stoller's avatar
Leigh B. Stoller committed
224
225
226
227
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
228
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
229
230
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
231
    }
232
233
234
235
236
237
238

    # 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) {
239
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
240
241
242
243
244
245
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
246
	my $user = GeniUser->Lookup($user_urn, 1);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
247
248
249
250
251
252
253
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
    #
    # 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
273
    #
274
    # Acquire the advertisement from ptopgen and compress it if requested.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
275
    #
276
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
277
    if (! defined($xml)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
278
279
280
281
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

282
283
284
285
286
287
    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
288
289
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
290

291
292
293
#
# Use ptopgen in xml mode to spit back an xml file. 
#
294
sub GetAdvertisement($$$$)
295
{
296
    my ($available, $pc, $version, $experiment) = @_;
297
298
    my $xml = undef;

299
300
301
302
303
304
305
    $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");

306
    my $invocation = "$PTOPGEN -x -g $version -r -p GeniSlices";
307
308
309
310
    if (defined($experiment)) {
	my $eid = $experiment->eid();
	$invocation .= " -e $eid";
    }
311
312
313
314
315
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
    if (open(AVAIL, "$invocation |")) {
316
	$xml = "";
317
318
319
320
321
322
323
324
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
    return $xml;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
325
#
326
# Update a ticket with a new rspec.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
327
#
328
sub UpdateTicket($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
329
330
{
    my ($argref) = @_;
331
332
333
334
335
336
337
338
339
340

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
341
    my $rspecstr   = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
342
    my $impotent   = $argref->{'impotent'};
343
344
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
345
346
347
348
349
350
351
    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
352

353
    if (! defined($credstr)) {
354
	return GeniResponse->MalformedArgsResponse();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
355
    }
356
    if (!defined($rspecstr)) {
357
358
	return GeniResponse->MalformedArgsResponse();
    }
359
360
361
362
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
363
364
365
366
    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

367
    if ($isupdate) {
368
369
370
	$ticket = CheckTicket($tickstr);
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
371
    }
372
    return GetTicketAux($credential,
373
			$rspecstr, $isupdate, $impotent, 0, 1, $ticket);
374
}
375

376
sub GetTicketAux($$$$$$$)
377
{
378
379
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level,
	$ticket) = @_;
380
    
381
382
383
384
385
386
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
387
    
388
389
    my $slice_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
390
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
391
    #
392
    # Create user from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
393
    #
394
    my $user = CreateUserFromCertificate($credential->owner_cert());
395
396
397
    return $user
	if (GeniResponse::IsResponse($user));
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
398
    #
399
    # Create slice from the certificate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
400
    #
401
402
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
403
	if ($isupdate) {
404
	    print STDERR "Could not locate slice $slice_urn for Update\n";
405
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
406
407
408
409
410
411
412
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
	if (!defined($slice)) {
	    print STDERR "Could not create $slice_urn\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create slice");
413
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
414
    }
415
    
416
    return GetTicketAuxAux($slice, $user, $rspecstr,
417
418
			   $isupdate, $impotent, $v2, $level, $ticket,
			   [$credential]);
419
}
420
sub GetTicketAuxAux($$$$$$$$$)
421
{
422
423
    my ($slice, $user, $rspecstr, 
        $isupdate, $impotent, $v2, $level, $ticket, $credentials) = @_;
424
425
426
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
427
428
    require OSinfo;
    require VirtExperiment;
429
430
431
432
433
434

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

439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
    #
    # 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");
    }

457
458
    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
459
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
460
				    "Error Parsing rspec XML");
461
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
462

Leigh B. Stoller's avatar
Leigh B. Stoller committed
463
464
465
466
    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
467
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
468
469
470
471
472
473
474
475
476
477
478
479
480
481
	    # 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
482
    }
483
484
485

    if (!$allow_externalusers && !$isExempted && !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
486
487
488
489
				    "External users temporarily denied");
    }
    
    #
490
    # For now all tickets expire very quickly (minutes), but once the
Leigh B. Stoller's avatar
Leigh B. Stoller committed
491
    # ticket is redeemed, it will expire according to the rspec request.
492
493
494
    # If nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
    # slice credential.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
495
    #
Jonathon Duerig's avatar
Jonathon Duerig committed
496
    my $expires = GeniXML::GetExpires($rspec);
497
    if (defined($expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
498
499
500
501
502
503
504
505
506
507
508
509
	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");
	}
	
	#
510
	# Do we need a policy limit?
511
512
513
  # A sitevar controls the sliver lifetime.
  #
  my $max_sliver_lifetime = 0;
514
  if (!GetSiteVar('protogeni/max_sliver_lifetime', \$max_sliver_lifetime)){
515
516
	    # Cannot get the value, default it to 90 days.
	    $max_sliver_lifetime = 90;
517
518
519
520
521
  }

  # 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) {
522
523
524
525
526
527
      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;
      }
528
  }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
529
	my $diff = $when - time();
530
	if ($diff < (60 * 5) || $diff > (3600 * 24 * $max_sliver_lifetime)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
531
532
533
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"valid_until out of range");
	}
534
535
536
537
538
539

	#
	# Must be before the slice expires.
	#
	my $slice_expires = $slice->expires();
	if (defined($slice_expires)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
540
	    $slice_expires = str2time($slice_expires);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
541
	    if ($when > $slice_expires) {
542
543
544
545
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "valid_until is past slice expiration");
	    }
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
546
    }
547
548
549
550
551
552
553

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
554
555
556
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
557
558
559
560
561
562
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
563
564
565
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
566
    }
567
568
569
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
570
571
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
572
573
574
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
575
576
577
578
579
580
581
582
    # 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
583

584
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
585
    # For now, there can be only a single toplevel aggregate per slice.
586
    # The existence of an aggregate means the slice is active here. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
587
    #
588
    my $aggregate = GeniAggregate->SliceAggregate($slice);
589
590
591
592
593
    if (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
594
595
	}
    }
596
597
598
599
600
    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;
    }
601
602
603
604

    #
    # Firewall hack; just a flag in the rspec for now.
    #
605
606
607
    my $needsfirewall = GeniXML::GetText("needsfirewall", $rspec);
    if (defined($needsfirewall)) {
	if ($slice->SetFirewallFlag($needsfirewall) != 0) {
608
609
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
610
611
	}
    }
612
613

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
614
    # We need this now so we can form a virtual topo.
615
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
616
617
618
619
620
621
622
623
    my $slice_experiment = GeniExperiment($slice);
    if (!defined($slice_experiment)) {
	print STDERR "Could not create new Geni slice experiment!\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();
624
625
626
627
628

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
629
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
630
631
    if (defined($generated_by) &&
	$generated_by eq "libvtop") {
632
633
634
635
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
636
637
638
639
640
641
642
643
644
645
646
647
648
    
    #
    # 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);
649
    $virtexperiment->multiplex_factor(3);
650

Leigh B. Stoller's avatar
Leigh B. Stoller committed
651
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
652
653
    # 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
654
655
    # cannot be granted.
    #
656
657
658
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
Jonathon Duerig's avatar
Jonathon Duerig committed
659
    my %iface2node = ();
660
    my %vportmap = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
661
    my %nodemap  = ();
662
    my @nodeids  = ();
663
    my %lannodes = ();
664
665
666
    # For stitching, keep track of external nodes and links.
    my %external_nodemap = ();
    my %external_linkmap = ();
667
668
669
670
671
672
673
674

    #
    # 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
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
	$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;
	}
693
694
695
696
697
698
699
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
700
	
701
	foreach my $ref (GeniXML::FindNodes("n:node",
702
					    $oldrspec)->get_nodelist()) {
703
	    # Let remote nodes pass through.
704
	    next
705
		if (!GeniXML::IsLocalNode($ref));
706

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

711
	    my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
712
	    my $colocate      = GeniXML::GetColocate($ref);
713
	    my $component_id  = GeniXML::GetNodeId($ref);
714
715
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
716
717
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
718
				 "Bad resource $component_id in ticket");
719
720
		goto bad;
	    }
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
	    #
	    # 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;
	    }
736
737
738
739
740
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
741

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

744
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
745
	my $component_id  = GeniXML::GetNodeId($ref);
746
	my $vnode_id      = GeniXML::GetVnodeId($ref);
747
	my $manager_id    = GeniXML::GetManagerId($ref);
748
	my $node_nickname = GeniXML::GetVirtualId($ref);
Jonathon Duerig's avatar
Jonathon Duerig committed
749
750
751
752
	my $colocate      = GeniXML::GetColocate($ref);
	my $subnode_of    = GeniXML::GetSubnodeOf($ref);
	my $virtualization_type = GeniXML::GetVirtualizationType($ref);
	
753
	my $virtualization_subtype
Jonathon Duerig's avatar
Jonathon Duerig committed
754
755
                          = GeniXML::GetVirtualizationSubtype($ref);
	my $exclusive     = GeniXML::GetExclusive($ref);
756
	my $pctype;
757
	my $osname;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
758
759
	my $node;

760
761
762
763
764
765
766
767
	# 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);
	    $iface2node{$virtual_id} = $node_nickname;
	}

768
	# Let remote nodes pass through.
769
770
771
772
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}
773

774
775
776
777
778
	#
	# 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. 
	#
779
	if (GeniXML::IsLanNode($ref)) {
780
781
782
783
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
	#
	# Check for disk_image request. Specified as a URN. 
	#
	my $diskref = GeniXML::FindFirst("n:disk_image", $ref);
	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;
		}
		#
807
808
		# For now, the project has to be emulab-ops or the
		# the current project.
809
		#
810
811
		if (! ($ospid eq TBOPSPID() ||
		       $ospid eq $slice_experiment->pid())) {
812
813
814
815
816
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Illegal project name in URN: $dname");
		    goto bad;
		}
817
		my $osinfo = OSinfo->Lookup($ospid, $os);
818
819
820
		if (!defined($osinfo)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
821
					     "Unknown image URN: $dname");
822
823
824
825
826
827
828
829
830
		    goto bad;
		}
		#
		# This is only going to be used in raw mode. 
		#
		$osname = $os;
	    }
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
831
832
833
	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
834
835
		    $pctype = "pcvm";
		    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
836
837
838
839
840
841
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
			$osname = "OPENVZ-STD";
		    }
842
843
844
845
		    elsif ($virtualization_subtype eq "emulab-spp") {
			$osname = "SPPVM-FAKE";
			$pctype = "sppvm";
			# Lets force to shared node.
Jonathon Duerig's avatar
Jonathon Duerig committed
846
			if (! GeniXML::SetExclusive($ref, 0)) {
847
848
849
			    $response
				= GeniResponse->Create(GENIRESPONSE_BADARGS,
						       undef,
850
851
				       "Malformed rspec: ".
				       "Cannot set exclusive tag to false");
852
853
854
			    goto bad;
			}
			$exclusive = 0;
855
856
			# Kludge for libvtop.
			$virtexperiment->multiplex_factor(1);
857
			$virtexperiment->encap_style("vlan");
858
		    }
859
860
861
862
863
864
865
866
		    elsif ($virtualization_subtype eq "emulab-bbg") {
			$osname = "BBGENIVM-FAKE";
			$pctype = "bbgenivm";
			# Lets force to shared node.
			GeniXML::SetExclusive($ref, 0);
			$exclusive = 0;
			$virtexperiment->encap_style("vlan");
		    }
867
868
		    elsif ($virtualization_subtype eq "raw"
			   || $virtualization_subtype eq "raw-pc") {
869
870
871
			$pctype = undef;
			goto raw;
		    }
872
873
874
875
876
877
878
879
		    else {
			$response
			    = GeniResponse->Create(GENIRESPONSE_BADARGS,
						   undef,
				       "Malformed rspec: ".
				       "Unknown virtualization_subtype");
			goto bad;
		    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
880
881
882
883
884
885
886
887
		}
		else {
		    goto raw;
		}
	    }
	    else {
	      raw:
		# Lets force to exclusive real node.
Jonathon Duerig's avatar
Jonathon Duerig committed
888
		if (! GeniXML::SetExclusive($ref, 1)) {
889
890
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
891
			"Malformed rspec: Cannot set exclusive tag to true");
892
893
894
		    goto bad;
		}
		$exclusive = 1;
895
		if (! GeniXML::SetVirtualizationSubtype($ref, "raw")) {
896
897
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
898
			"Malformed rspec: Cannot set virtualization_type to raw");
899
900
		    goto bad;
		}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
901
902
903
904
	    }
	}
	else {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
905
				     "Must provide a virtualization_type");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
906
907
908
	    goto bad;

	}
909
910
911
912
913
914
	if (!defined($node_nickname)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtual_id for nodes");
	    goto bad;
	}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
915
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
916
	# Allow wildcarding.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
917
	#
918
	if (!defined($component_id) || $component_id eq "*") {
919
920
921
922
923
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
924
	    }
925
926
	    # If the node still isn't bound and doesn't have a pctype,
	    # use the user-specified one.
927
928
929
930
931
932
933
934
935
	    if (GeniXML::IsVersion0($ref)) {
		if (! defined($node) && ! defined($pctype)) {
		    my $usertype = GeniXML::FindFirst("n:node_type", $ref);
		    if (defined($usertype)) {
			$pctype = GeniXML::GetText("type_name", $usertype);
		    }
		}
	    } else {
		my $usertype = GeniXML::FindFirst("n:hardware_type", $ref);
936
		if (defined($usertype)) {
937
		    $pctype = GeniXML::GetText("name", $usertype);
938
939
		}
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
940
941
	}
	else {
942
	    $node = GeniUtil::LookupNode($vnode_id);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
943
944
945
946

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
947
					 "Bad resource $component_id");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
948
949
		goto bad;
	    }
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
	    #
	    # Is the node a virtual node? Must be an update to an
	    # existing sliver/ticket, since we now return the node_id
	    # of the allocated virtual node, not the physical node.
	    #
	    if ($node->isvirtnode()) {
		if (!$isupdate ||
		    !exists($namemap{$node_nickname})) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Bad resource for $node_nickname");
		    goto bad;
		}
		$node = $namemap{$node_nickname};
	    }
965
966
	    $pctype = $node->type()
		if (!defined($pctype));
967
968
	}
	#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
969
	# If no osname by this point, try for the default.
970
971
	#
	if (defined($node) && !defined($osname)) {
972
973
974
975
976
	    if (defined($node->default_osid())) {	    
		my $osinfo = OSinfo->Lookup($node->default_osid());
		$osname = $osinfo->osname()
		    if (defined($osinfo));
	    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
977
	}
978
979
980
	# The slot does not like to be NULL.
	$osname = ""
	    if (!defined($osname));
981
	
982
983
984
	# Need some kind of default.
	$pctype = "pc"
	    if (!defined($pctype));
985
	
986
987
988
989
990
	my $nodeblob = {"vname"   => $node_nickname,
			"type"    => $pctype,
			"osname"  => $osname,
			"ips"     => '', # deprecated
			"cmd_line"=> '', # bogus
Leigh B. Stoller's avatar
Leigh B. Stoller committed
991
992
			"fixed"   => (defined($subnode_of) ? $subnode_of :
				      defined($node) ? $node->node_id() : ""),
993
			};
994
995

	# Tarball and startup command.
996
	my $startupcmd = GeniXML::GetStartupCommand($ref);
997
	if (defined($startupcmd)) {
998
999
1000
	    if (! TBcheck_dbslot($startupcmd, "virt_nodes", "startupcmd",
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		$response =
For faster browsing, not all history is shown. View entire blame