GeniCM.pm.in 21.2 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008 University of Utah and the Flux Group.
# 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 ( );

# Must come after package declaration!
use lib '@prefix@/lib';
use GeniDB;
use Genixmlrpc;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
24 25
use GeniResponse;
use GeniTicket;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
26
use GeniCredential;
27
use GeniCertificate;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
28
use GeniSlice;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
use GeniAggregate;
30
use GeniAuthority;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
31
use GeniSliver;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
32
use GeniUser;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
33
use libtestbed;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
34 35 36
# Hate to import all this crap; need a utility library.
use libdb qw(TBGetUniqueIndex TBcheck_dbslot TBDB_CHECKDBSLOT_ERROR);
use User;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
37
use Node;
38
use Interface;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
39 40
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
41
use XML::Simple;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42
use Experiment;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
43 44 45 46 47 48 49 50

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
51 52
my $CREATEEXPT     = "$TB/bin/batchexp";
my $NALLOC	   = "$TB/bin/nalloc";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
53
my $AVAIL	   = "$TB/sbin/avail";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
54 55
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
56 57 58 59 60 61 62

#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
63
    my $slice      = $argref->{'slice'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
64 65
    my $credential = $argref->{'credential'};
    my $user_uuid  = $ENV{'GENIUSER'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
66
    my $slice_uuid;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
67

Leigh B. Stoller's avatar
Leigh B. Stoller committed
68
    if (! defined($slice)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
69 70 71 72 73 74 75 76
	return GeniResponse->MalformedArgsResponse();
    }

    $credential = GeniCredential->CreateFromSigned($credential);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
77
    GeniCertificate->CertificateInfo($slice, \$slice_uuid) == 0 or
Leigh B. Stoller's avatar
Leigh B. Stoller committed
78 79 80
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not get uuid from Certificate");
	
Leigh B. Stoller's avatar
Leigh B. Stoller committed
81 82 83 84 85 86 87 88 89 90 91
    # The credential owner/slice has to match what was provided.
    if (! ($user_uuid eq $credential->owner_uuid() &&
	   $slice_uuid eq $credential->this_uuid())) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }

    #
    # Eventually we will take an optional rspec, but for now just return
    # a list of free nodes using avail. 
    #
92 93
    my @nodelist = ();
    if (! open(AVAIL, "$AVAIL type=pc  aslist |")) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
94 95 96 97 98 99 100 101 102 103 104 105
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }
    while (<AVAIL>) {
	my $nodeid = $_;
	chomp($nodeid);
	my $node = Node->Lookup($nodeid);
	push(@nodelist, $node)
	    if (defined($node));
    }
    close(AVAIL);

Leigh B. Stoller's avatar
Leigh B. Stoller committed
106
    my $xml = "<rspec xmlns=\"http://protogeni.net/resources/rspec/0.1\">\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
107 108 109 110 111 112
    foreach my $node (@nodelist) {
	my $uuid = $node->uuid();
	my $nodeid = $node->node_id();
	
	$xml .= "<node uuid=\"$uuid\" name=\"$nodeid\">".
	    "<available>true</available></node>\n";
113 114 115 116 117 118 119 120 121 122 123 124

	my @interfaces = Interface->LookupAll($node);
	foreach my $interface (@interfaces) {
	    my $iface_uuid = $interface->uuid();
	    my $iface      = $interface->iface();

	    next 
		if (! $interface->IsExperimental());
	    
	    $xml .= "<interface uuid=\"$iface_uuid\" node_name=\"$nodeid\">".
		"<iface>$iface</iface></interface>\n";
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
125 126 127 128 129
    }
    $xml .= "</rspec>";

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
130

Leigh B. Stoller's avatar
Leigh B. Stoller committed
131
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
132
# Respond to a GetTicket request. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
133 134 135 136
#
sub GetTicket($)
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
137
    my $slice_cert = $argref->{'slice'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
138
    my $rspec      = $argref->{'rspec'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
139
    my $impotent   = $argref->{'impotent'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
140
    my $credential = $argref->{'credential'};
141
    my $vtopo      = $argref->{'virtual_topology'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
142
    my $owner_uuid = $ENV{'GENIUSER'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
143
    my $slice_uuid;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
144

Leigh B. Stoller's avatar
Leigh B. Stoller committed
145
    if (! defined($slice_cert)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
146
	GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
147
			     "Improper slice");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
148
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
149 150 151
    if (! (defined($rspec) && ($rspec =~ /^[-\w]+$/))) {
	GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			     "Improper rspec");	
Leigh B. Stoller's avatar
Leigh B. Stoller committed
152
    }
153 154
    $rspec = XMLin($rspec, ForceArray => ["node", "link"]);
    #print Dumper($rspec);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
155

Leigh B. Stoller's avatar
Leigh B. Stoller committed
156 157 158
    $impotent = 0
	if (!defined($impotent));

Leigh B. Stoller's avatar
Leigh B. Stoller committed
159
    $credential = GeniCredential->CreateFromSigned($credential);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
160 161 162 163
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
164
    GeniCertificate->CertificateInfo($slice_cert, \$slice_uuid) == 0 or
Leigh B. Stoller's avatar
Leigh B. Stoller committed
165 166 167 168
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not get uuid from Certificate");
	
	
Leigh B. Stoller's avatar
Leigh B. Stoller committed
169 170 171 172 173 174
    # The credential owner/slice has to match what was provided.
    if (! ($owner_uuid eq $credential->owner_uuid() &&
	   $slice_uuid eq $credential->this_uuid())) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
175

Leigh B. Stoller's avatar
Leigh B. Stoller committed
176 177 178 179 180 181 182
    #
    # See if we have a record of this slice in the DB. If not, then we have
    # to go to the ClearingHouse to find its record, so that we can find out
    # who the SA for it is.
    #
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
183
	$slice = CreateSliceFromRegistry($slice_uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
184 185 186 187 188
	if (!defined($slice)) {
	    print STDERR "No slice $slice_uuid in the ClearingHouse\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Could not get slice info from ClearingHouse");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
189
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
190
    else {
191
	UpdateSliceFromRegistry($slice) == 0 or
Leigh B. Stoller's avatar
Leigh B. Stoller committed
192 193 194
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			"Could not update slice info from ClearingHouse");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
195

Leigh B. Stoller's avatar
Leigh B. Stoller committed
196
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
197 198 199 200
    # Ditto the user.
    #
    my $user = GeniUser->Lookup($owner_uuid);
    if (!defined($user)) {
201
	$user = CreateUserFromRegistry($owner_uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
202 203 204 205 206 207 208
	if (!defined($user)) {
	    print STDERR "No user $owner_uuid in the ClearingHouse\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Could not get user info from ClearingHouse");
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
209
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
210 211 212 213
    # If the underlying experiment does not exist, need to create
    # a holding experiment. All these are going to go into the same
    # project for now. Generally, users for non-local slices do not
    # have local accounts or directories.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
214
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
215 216 217 218 219 220 221 222 223
    my $experiment = Experiment->Lookup($slice_uuid);
    if (!defined($experiment)) {
	#
	# Form an eid for the experiment. 
	#
	my $eid = "slice" . TBGetUniqueIndex('next_sliceid', 1);

	# Note the -h option; allows experiment with no NS file.
	system("$CREATEEXPT -q -i -w -E 'Geni Slice Experiment' ".
Leigh B. Stoller's avatar
Leigh B. Stoller committed
224
	       "-h '$slice_uuid' -p GeniSlices -e $eid");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
225 226 227 228 229 230 231
	if ($?) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Internal Error");
	}
	$experiment = Experiment->Lookup($slice_uuid);
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
232
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
233 234 235
    # An rspec is a structure that requests specific nodes. If those
    # nodes are available, then reserve it. Otherwise the ticket
    # cannot be granted. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
236
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
237
    my @nodeids = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
238 239 240
    my $pid     = $experiment->pid();
    my $eid     = $experiment->eid();

241 242 243
    foreach my $resource_uuid (keys(%{$rspec->{'node'}})) {
	my $node = Node->Lookup($resource_uuid);
	if (!defined($node)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
244
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
245
					"Bad resource_uuid $resource_uuid");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
246
	}
247
	push(@nodeids, $node->node_id());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
248
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
249 250

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
251
    # Create the ticket first, before allocating the node.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
252
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
253
    my $ticket = GeniTicket->Create($slice, $user, $rspec);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
254 255 256 257
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
258
    # Nalloc might fail if the node gets picked up by someone else.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
259
    if (!$impotent) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
260
	system("$NALLOC $pid $eid @nodeids");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
261 262 263 264 265 266 267 268 269 270
	if (($? >> 8) < 0) {
	    $ticket->Delete();
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Allocation failure");
	}
	elsif (($? >> 8) > 0) {
	    $ticket->Delete();
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"Could not allocate node\n");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
271
    }
272 273 274 275 276 277 278
    if (defined($vtopo) && $experiment->InsertVirtTopo($vtopo) != 0) {
	# Release will free the nodes.
	$ticket->Release();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not insert virt topology");
    }
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
279
    if ($ticket->Sign() != 0) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
280
	# Release will free the nodes.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
281
	$ticket->Release();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
282 283 284
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not sign Ticket");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
285 286 287 288 289 290 291 292 293 294
    return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				$ticket->asString());
}

#
# Create a sliver.
#
sub CreateSliver($)
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
295 296
    my $owner_uuid = $ENV{'GENIUSER'};
    my $ticket     = $argref->{'ticket'};
297
    my $impotent   = $argref->{'impotent'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
298
    my $message    = "Error creating sliver/aggregate";
299 300 301

    $impotent = 0
	if (!defined($impotent));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
302 303 304 305 306 307 308 309 310 311 312 313

    if (! (defined($ticket) &&
	   !TBcheck_dbslot($ticket, "default", "text",
			   TBDB_CHECKDBSLOT_ERROR))) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "ticket: ". TBFieldErrorString());
    }
    $ticket = GeniTicket->CreateFromSignedTicket($ticket);
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
314 315 316 317 318
    # The credential owner has to match what is in the ticket.
    if ($owner_uuid ne $ticket->owner_uuid()) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
319

Leigh B. Stoller's avatar
Leigh B. Stoller committed
320 321 322 323 324
    my $experiment = Experiment->Lookup($ticket->slice_uuid());
    if (!defined($experiment)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local experiment for slice");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
325 326
    my $pid = $experiment->pid();
    my $eid = $experiment->eid();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
327

328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
    #
    # See if we have a record of this slice in the DB. If not, throw an
    # error; might change later.
    #
    my $slice = GeniSlice->Lookup($ticket->slice_uuid());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }

    #
    # Ditto the user.
    #
    my $owner = GeniUser->Lookup($owner_uuid);
    if (!defined($owner)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No user record for $owner_uuid");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
347 348 349 350 351 352
    #
    # Create an emulab nonlocal user for tmcd.
    #
    $owner->BindToSlice($slice) == 0
	or return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				       "Error binding user to slice");
353

Leigh B. Stoller's avatar
Leigh B. Stoller committed
354 355 356 357 358 359 360 361 362 363 364 365 366 367
    # Bind the other users too.
    my @userbindings;
    if ($slice->UserBindings(\@userbindings) != 0) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Error binding users to slice");
    }
    foreach my $otheruuid (@userbindings) {
	my $otheruser = GeniUser->Lookup($otheruuid);
	
	if (!$otheruser->BindToSlice($slice) != 0) {
	    print STDERR "Could not bind $otheruser to $slice\n";
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
368
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
369
    # We are actually an Aggregate, so return an aggregate of slivers,
370
    # unless there is just one node.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
371
    #
372 373 374 375 376
    my $aggregate;
    if (scalar(keys(%{$ticket->rspec()->{'node'}})) > 1) {
	$aggregate = GeniAggregate->Create($ticket);
	if (!defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
377
				    "Could not create GeniAggregate object");
378
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
379
    }
380
    #print Dumper($ticket);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
381 382

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
383 384
    # Now for each resource (okay, node) in the ticket create a sliver and
    # add it to the aggregate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
385
    #
386
    my %slivers = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
387
    foreach my $resource_uuid (keys(%{$ticket->rspec()->{'node'}})) {
388 389 390
	my $node = Node->Lookup($resource_uuid);
	if (!defined($node)) {
	    $message = "Unknown resource_uuid in ticket: $resource_uuid";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
391 392
	    goto bad;
	}
393
	my $sliver = GeniSliver::Node->Create($slice, $owner, $resource_uuid);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
394 395 396 397
	if (!defined($sliver)) {
	    $message = "Could not create GeniSliver object for $resource_uuid";
	    goto bad;
	}
398
	$slivers{$resource_uuid} = $sliver;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
399
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
400

401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458
    #
    # Now do the links. For each link, we have to add a sliver for the
    # interfaces, and then combine those two interfaces into an aggregate,
    # and then that aggregate goes into the aggregate for toplevel sliver.
    #
    foreach my $linkname (keys(%{$ticket->rspec()->{'link'}})) {
	my @linkslivers  = ();
	if (! ($linkname =~ /^[-\w]*$/)) {
	    $message = "Bad name for link: $linkname";
	    goto bad;
	}

	my $linkaggregate = GeniAggregate::Link->Create($ticket);
	if (!defined($linkaggregate)) {
	    $message = "Could not create link aggregate for $linkname";
	    goto bad;
	}
	$slivers{$linkaggregate->uuid()} = $linkaggregate;

	my $linkendpoints =
	    $ticket->rspec()->{'link'}->{$linkname}->{'LinkEndPoints'};
	
	my $src_interface_spec = $linkendpoints->{'source_interface'};
	my $dst_interface_spec = $linkendpoints->{'destination_interface'};

	my @interfaces = ($src_interface_spec, $dst_interface_spec);
	foreach my $iface (@interfaces) {
	    my $node_uuid = $iface->{'node_uuid'};
	    my $iface     = $iface->{'iface_name'};
	    my $nodesliver= $slivers{$node_uuid};
	    if (!defined($nodesliver)) {
		$message = "Link $linkname specifies a non-existent node";
		goto bad;
	    }
	    my $nodeobject= Node->Lookup($node_uuid);
	    if (!defined($nodeobject)) {
		$message = "Could not find node object for $node_uuid";
		goto bad;
	    }
	    my $interface = Interface->LookupByIface($nodeobject, $iface);
	    if (!defined($interface)) {
		$message = "No such interface $iface on node $nodeobject";
		goto bad;
	    }
	    my $sliver = GeniSliver::Interface->Create($slice, $owner,
						       $interface->uuid());
	    if (!defined($sliver)) {
		$message = "Could not create GeniSliver ".
		    "$interface in $linkname";
		goto bad;
	    }
	    if ($sliver->SetAggregate($linkaggregate) != 0) {
		$message = "Could not add link sliver $sliver to $aggregate";
		goto bad;
	    }
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
459 460 461 462
    #
    # Now do the provisioning (note that we actually allocated the node
    # above when the ticket was granted). The add the sliver to the aggregate.
    #
463
    foreach my $sliver (values(%slivers)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
464 465 466
	if (!$impotent && $sliver->Provision() != 0) {
	    $message = "Could not provision $sliver";
	    goto bad;
467

Leigh B. Stoller's avatar
Leigh B. Stoller committed
468
	}
469 470
	if (defined($aggregate) &&
	    $sliver->SetAggregate($aggregate) != 0) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
471 472 473 474 475
	    $message = "Could not aggregate for $sliver to $aggregate";
	    goto bad;
	}
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
476
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
477
    # The API states we return a credential to control the sliver/aggregate.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
478
    #
479 480 481 482 483 484 485
    my $credential;
    if (defined($aggregate)) {
	$credential = $aggregate->NewCredential($owner);
    }
    else {
	$credential = ((values(%slivers))[0])->NewCredential($owner);
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
486
    if (!defined($credential)) {
487
	$message = "Could not create credential";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
488
	goto bad;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
489 490
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $credential->asString());
Leigh B. Stoller's avatar
Leigh B. Stoller committed
491 492

  bad:
493
    foreach my $sliver (values(%slivers)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
494 495 496 497 498 499 500 501
	$sliver->UnProvision()
	    if (! $impotent);
	$sliver->Delete();
    }
    $aggregate->Delete()
	if (defined($aggregate));
    
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef, $message);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
502 503 504
}

#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
505
# Start a sliver (not sure what this means yet, so reboot for now).
Leigh B. Stoller's avatar
Leigh B. Stoller committed
506
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
507
sub StartSliver($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
508 509
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
510
    my $owner_uuid  = $ENV{'GENIUSER'};
511
    my $sliver_cert = $argref->{'sliver'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
512
    my $credential  = $argref->{'credential'};
513
    my $sliver_uuid;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
514 515 516 517
    my $impotent   = $argref->{'impotent'};

    $impotent = 0
	if (!defined($impotent));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
518

519
    if (!defined($sliver_cert) || !defined($credential)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
520 521
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
522 523 524 525
    GeniCertificate->CertificateInfo($sliver_cert, \$sliver_uuid) == 0 or
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not get uuid from Certificate");
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
526 527 528 529 530
    $credential = GeniCredential->CreateFromSigned($credential);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
531 532
    my $sliver = GeniSliver->Lookup($sliver_uuid);
    if (!defined($sliver)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
533 534 535 536 537 538
	# Might be an aggregate instead.
	$sliver = GeniAggregate->Lookup($sliver_uuid);
	if (!defined($sliver)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "No such sliver/aggregate $sliver_uuid");
	}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
539
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
540 541 542 543 544 545 546 547
    
    # The credential owner has to match what is in the ticket.
    if (! ($owner_uuid eq $credential->owner_uuid() &&
	   $sliver_uuid eq $credential->this_uuid())) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }
    if (!$impotent) {
548
	$sliver->Start() == 0 or
Leigh B. Stoller's avatar
Leigh B. Stoller committed
549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not start sliver/aggregate");
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Destroy a sliver/aggregate.
#
sub DestroySliver($)
{
    my ($argref) = @_;
    my $owner_uuid  = $ENV{'GENIUSER'};
    my $sliver_cert = $argref->{'sliver'};
    my $credential  = $argref->{'credential'};
    my $sliver_uuid;
    my $impotent   = $argref->{'impotent'};

    $impotent = 0
	if (!defined($impotent));

    if (!defined($sliver_cert) || !defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    GeniCertificate->CertificateInfo($sliver_cert, \$sliver_uuid) == 0 or
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not get uuid from Certificate");
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
577 578
    $credential = GeniCredential->CreateFromSigned($credential);
    if (!defined($credential)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
579
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
580
				    "Could not create GeniCredential object");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
581
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
582 583 584 585 586 587 588 589 590 591
    my $sliver = GeniSliver->Lookup($sliver_uuid);
    if (!defined($sliver)) {
	# Might be an aggregate instead.
	$sliver = GeniAggregate->Lookup($sliver_uuid);
	if (!defined($sliver)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "No such sliver/aggregate $sliver_uuid");
	}
    }
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
592 593 594 595 596
    # The credential owner has to match what is in the ticket.
    if (! ($owner_uuid eq $credential->owner_uuid() &&
	   $sliver_uuid eq $credential->this_uuid())) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
597
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
598 599 600 601 602
    if (!$impotent) {
	$sliver->UnProvision() == 0 or
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not unprovision sliver/aggregate");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
603 604
    $sliver->Delete() == 0 or
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
605
				    "Could not delete sliver/aggregate");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
606 607
    
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
608
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
609

610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
#
# Utility Routines.
#
# Create a slice from the ClearingHouse, by looking up the info.
#
sub CreateSliceFromRegistry($)
{
    my ($slice_uuid) = @_;

    my $blob;
    return undef
	if (GeniCHClient::LookupSlice($slice_uuid, \$blob) != 0);

    my $authority = GeniAuthority->Lookup($blob->{'sa_uuid'});
    if (!defined($authority)) {
	$authority = CreateAuthorityFromRegistry($blob->{'sa_uuid'});
	if (!defined($authority)) {
	    print STDERR "Could not create new authority record\n";
	    return undef;
	}
    }
    my $slice = GeniSlice->Create($blob->{'hrn'},
				  $blob->{'uuid'},
				  $blob->{'creator_uuid'},
				  $blob->{'cert'}, $authority);
    return undef
	if (!defined($slice));

    # Add the user bindings.
    foreach my $uuid (@{ $blob->{'userbindings'} }) {
	my $user = GeniUser->Lookup($uuid);
	if (!defined($user)) {
	    $user = CreateUserFromRegistry($uuid);
	    if (!defined($user)) {
		print STDERR "No user $uuid in the ClearingHouse\n";
		next;
	    }
	}
	DBQueryWarn("replace into geni_bindings set ".
		    " created=now(), slice_uuid='$slice_uuid', ".
		    " user_uuid='$uuid'")
	    or print STDERR
	    "Could not insert user binding for $uuid to slice $slice_uuid\n";
    }
    return $slice;
}

#
# Update slice from the ClearingHouse, by looking up the info.
#
sub UpdateSliceFromRegistry($)
{
    my ($slice) = @_;
    my $slice_uuid = $slice->uuid();

    my $blob;
    return -1
	if (GeniCHClient::LookupSlice($slice_uuid, \$blob) != 0);

    DBQueryWarn("delete from geni_bindings ".
		"where slice_uuid='$slice_uuid'")
	or print STDERR
	"Could not delete user bindings from slice $slice_uuid\n";

    # Add the user bindings.
    foreach my $uuid (@{ $blob->{'userbindings'} }) {
	my $user = GeniUser->Lookup($uuid);
	if (!defined($user)) {
	    $user = CreateUserFromRegistry($uuid);
	    if (!defined($user)) {
		print STDERR "No user $uuid in the ClearingHouse\n";
		next;
	    }
	}
	DBQueryWarn("replace into geni_bindings set ".
		    " created=now(), slice_uuid='$slice_uuid', ".
		    " user_uuid='$uuid'")
	    or print STDERR
	    "Could not insert user binding for $uuid to slice $slice_uuid\n";
    }
    return 0;
}

#
# Create a user from the ClearingHouse, by looking up the info.
#
sub CreateUserFromRegistry($)
{
    my ($uuid) = @_;

    my $blob;
    return undef
	if (GeniCHClient::LookupUser($uuid, \$blob) != 0);

    my $authority = GeniAuthority->Lookup($blob->{'sa_uuid'});
    if (!defined($authority)) {
	$authority = CreateAuthorityFromRegistry($blob->{'sa_uuid'});
	if (!defined($authority)) {
	    print STDERR "Could not create new authority record\n";
	    return undef;
	}
    }
    return GeniUser->Create($blob->{'hrn'},
			    $blob->{'uid'},
			    $blob->{'uuid'},
			    $blob->{'name'},
			    $blob->{'email'},
			    $blob->{'cert'},
			    $authority,
			    (exists($blob->{'sshkey'}) ?
			     $blob->{'sshkey'} : undef));
}

#
# Create authority from the ClearingHouse, by looking up the info.
#
sub CreateAuthorityFromRegistry($)
{
    my ($uuid) = @_;

    my $blob;
    return undef
	if (GeniCHClient::Resolve($uuid, "SA", \$blob) != 0);

    return GeniAuthority->Create($uuid,
				 $blob->{'hrn'},
				 $blob->{'url'},
				 $blob->{'cert'},
				 $blob->{'uuid_prefix'}, "sa");
}