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");
}