#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008-2009 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;
use GeniResponse;
use GeniTicket;
use GeniCredential;
use GeniCertificate;
use GeniSlice;
use GeniAggregate;
use GeniAuthority;
use GeniSliver;
use GeniUser;
use GeniRegistry;
use libtestbed;
# Hate to import all this crap; need a utility library.
use libdb qw(TBGetUniqueIndex TBcheck_dbslot TBGetSiteVar
	     TBDB_CHECKDBSLOT_ERROR);
use User;
use Node;
use libadminctrl;
use Interface;
use English;
use Data::Dumper;
use XML::Simple;
use Date::Parse;
use POSIX qw(strftime);
use Time::Local;
use Experiment;
use Firewall;

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
my $CREATEEXPT     = "$TB/bin/batchexp";
my $ENDEXPT        = "$TB/bin/endexp";
my $NALLOC	   = "$TB/bin/nalloc";
my $NFREE	   = "$TB/bin/nfree";
my $AVAIL	   = "$TB/sbin/avail";
my $PTOPGEN	   = "$TB/libexec/ptopgen";
my $TBSWAP	   = "$TB/bin/tbswap";
my $SWAPEXP	   = "$TB/bin/swapexp";
my $PLABSLICE	   = "$TB/sbin/plabslicewrapper";
my $NAMEDSETUP     = "$TB/sbin/named_setup";
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";

#
# Respond to a Resolve request. 
#
sub Resolve($)
{
    my ($argref) = @_;
    my $uuid       = $argref->{'uuid'};
    my $cred       = $argref->{'credential'};
    my $type       = $argref->{'type'};
    my $hrn;

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
    if (! (defined($type) && ($type =~ /^(Node)$/))) {
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
    if (! defined($uuid)) {
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && !($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->MalformedArgsResponse();
    }

    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    
    #
    # Make sure the credential was issued to the caller, but no special
    # permission required to resolve component resources.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
    if ($type eq "Node") {
	my $node;
	
	if (defined($uuid)) {
	    $node= Node->Lookup($uuid);
	}
	else {
	    #
	    # We only want the last token for node lookup.
	    #
	    if ($hrn =~ /\./) {
		($hrn) = ($hrn =~ /\.(\w*)$/);
	    }
	    $node= Node->Lookup($hrn);
	}
	if (!defined($node)) {
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}
	
	# Return a blob.
	my $blob = { "hrn"          => "${OURDOMAIN}." . $node->node_id(),
		     "uuid"         => $node->uuid(),
		     "role"	    => $node->role(),
		   };

	#
	# Get the list of interfaces for the node.
	#
	my @interfaces;
	if ($node->AllInterfaces(\@interfaces) != 0) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not get interfaces for $uuid");
	}

	my @iblobs = ();
	foreach my $interface (@interfaces) {
	    next
		if (!defined($interface->switch_id()));
		
	    my $iblob = { "uuid"	=> $interface->uuid(),
			  "iface"	=> $interface->iface(),
			  "type"	=> $interface->type(),
			  "card"	=> $interface->card(),
			  "port"	=> $interface->port(),
			  "role"	=> $interface->role(),
			  "IP"		=> $interface->IP() || "",
			  "mask"	=> $interface->mask() || "",
			  "MAC"		=> $interface->mac(),
			  "switch_id"   => "${OURDOMAIN}." . 
			      $interface->switch_id(),
			  "switch_card"	=> $interface->switch_card(),
			  "switch_port"	=> $interface->switch_port(),
			  "wire_type"	=> $interface->wire_type(),
		      };

	    push(@iblobs, $iblob);
	}
	$blob->{'interfaces'} = \@iblobs
	    if (@iblobs);
	
	return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
    }
    return GeniResponse->Create(GENIRESPONSE_UNSUPPORTED);
}

#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
    my ($argref) = @_;
    my $credential = $argref->{'credential'};
    my $user_uuid  = $ENV{'GENIUSER'};

    $credential = GeniCredential->CreateFromSigned($credential);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    # The credential owner/slice has to match what was provided.
    if ($user_uuid ne $credential->owner_uuid()) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Invalid credentials for operation");
    }

    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!TBGetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
	# Cannot get the value, say no.
	$allow_externalusers = 0;
    }
    if (!$allow_externalusers) {
	my $user = GeniUser->Lookup($user_uuid, 1);
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

    #
    # Use ptopgen in xml mode to spit back an xml file. 
    #
    if (! open(AVAIL, "$PTOPGEN -x -g -r -p GeniSlices |")) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }
    my $xml = "";
    while (<AVAIL>) {
	$xml .= $_;
    }
    close(AVAIL);

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

#
# Respond to a GetTicket request. 
#
sub GetTicket($)
{
    my ($argref) = @_;
    my $rspec      = $argref->{'rspec'};
    my $impotent   = $argref->{'impotent'};
    my $cred       = $argref->{'credential'};
    my $vtopo      = $argref->{'virtual_topology'};
    my $owner_uuid = $ENV{'GENIUSER'};
    my $response   = undef;

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
    if (! (defined($rspec) && ($rspec =~ /^[-\w]+$/))) {
	GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			     "Improper rspec");	
    }
    $rspec = XMLin($rspec, ForceArray => ["node", "link", "linkendpoints"]);

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

    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();
    

    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    #
    # Create slice form the certificate.
    #
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	$slice = CreateSliceFromCertificate($credential);
	if (!defined($slice)) {
	    print STDERR "Could not create $slice_uuid\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create slice");
	}
    }

    #
    # Ditto the user.
    #
    my $user = GeniUser->Lookup($user_uuid);
    if (!defined($user)) {
	$user = CreateUserFromCertificate($credential->owner_cert());
	if (!defined($user)) {
	    print STDERR "No user $user_uuid in the ClearingHouse\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Could not get user info from ClearingHouse");
	}
    }

    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!TBGetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
	# Cannot get the value, say no.
	$allow_externalusers = 0;
    }
    if (!$allow_externalusers && !$user->IsLocal()) {
	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				    "External users temporarily denied");
    }
    
    #
    # For now all tickets expire very quickly (minutes), but once the
    # ticket is redeemed, it will expire according to the rspec request.
    #
    if (exists($rspec->{'valid_until'})) {
	my $expires = $rspec->{'valid_until'};

	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");
	}
	
	#
	# No more then 24 hours out ... Needs to be a sitevar?
	#
	my $diff = $when - time();
	if ($diff < (60 * 15) || $diff > (3600 * 24)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"valid_until out of range");
	}
    }
    else {
	# Give it a reasonable default for later when the ticket is redeemed.
	$rspec->{'valid_until'} =
	    POSIX::strftime("20%y-%m-%dT%H:%M:%S", gmtime(time() + (3600*1)));
    }
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }

    #
    # For now, there can be only a single toplevel aggregate per slice.
    # The existence of an aggregate means the slice is active here. 
    #
    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (defined($aggregate)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Already have an aggregate for slice");
    }

    #
    # Say a ticket already exists in the DB? Lets throw that ticket
    # away and generate a new one. This is partly a debugging
    # mechanism.  To really do this correctly, would want to merge in
    # the existing resources with the new rspec request. Do not
    # want to go there yet.
    #
    my $existing_ticket = GeniTicket->LookupForSlice($slice);
    if (defined($existing_ticket)) {
	print STDERR "Releasing existing ticket $existing_ticket\n";
	if ($existing_ticket->Release(TICKET_EXPIRED) != 0) {
	    print STDERR "Error releasing existing ticket $existing_ticket\n";
	    $slice->UnLock();
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
    }

    #
    # Firewall hack; just a flag in the rspec for now.
    #
    if (exists($rspec->{'needsfirewall'}) && $rspec->{'needsfirewall'}) {
	print STDERR "firewall: " . $rspec->{'needsfirewall'} . "\n";
	if ($slice->SetFirewallFlag($rspec->{'needsfirewall'}) != 0) {
	    $slice->UnLock();
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
    }
    
    my $experiment = GeniExperiment($slice);
    if (!defined($experiment)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR,
				    undef, "Internal Error");
    }

    #
    # An rspec is a structure that requests specific nodes. If those
    # nodes are available, then reserve it. Otherwise the ticket
    # cannot be granted.
    #
    # XXX Simpleminded.
    #
    my %namemap = ();
    my %uuidmap = ();
    my @nodeids = ();
    my @dealloc;
    my $pid     = $experiment->pid();
    my $eid     = $experiment->eid();

    foreach my $ref (@{$rspec->{'node'}}) {
	my $resource_uuid = $ref->{'uuid'};
	my $node_nickname = $ref->{'nickname'};
	my $virtualization_type = $ref->{'virtualization_type'};
	my $node;

	#
	# Mostly for debugging right now, allow a wildcard.
	#
	if ($resource_uuid eq "*") {
	    $node = FindFreeNode($virtualization_type, @nodeids);
	    
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_UNAVAILABLE,
						 undef,
						 "No free nodes for wildcard");
		goto bad;
	    }
	    $resource_uuid = $node->uuid();
	    $ref->{'uuid'} = $node->uuid();
	}
	else {
	    $node = Node->Lookup($resource_uuid);

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad resource $resource_uuid");
		goto bad;
	    }
	}
	#
	# Widearea nodes do not need to be allocated, but for now all
	# I allow is a plabdslice node.
	#
	if ($node->isremotenode()) {
	    if (! $node->isplabphysnode()) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Only plab widearea nodes");
		goto bad;
	    }
	    next;
	}

	#
	# See if the node is already reserved.
	#
	my $reservation = $node->Reservation();
	if (defined($reservation)) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				     "$resource_uuid ($node) not available");
	    goto bad;
	}
	push(@nodeids, $node->node_id());
	$uuidmap{$resource_uuid} = $node;
	# For wildcarded nodes in links.
	$namemap{$node_nickname} = $node
	    if (defined($node_nickname));
    }

    #
    # A sitevar controls how many total nodes external users can allocate.
    #
    # XXX All this policy stuff is a whack job for the initial release. 
    #
    my $max_externalnodes = 0;
    if (!TBGetSiteVar('protogeni/max_externalnodes', \$max_externalnodes)){
	# Cannot get the value, say none.
	$max_externalnodes = 0;
    }
    if (scalar(@nodeids) > $max_externalnodes) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
			   "Too many nodes; limited to $max_externalnodes");
    }
    # Check current usage by dipping into the libadminctrl library.
    my $curusage = libadminctrl::LoadCurrent($experiment->creator(),
					     $experiment->pid(),
					     $experiment->gid());
    if (!defined($curusage)) {
	$slice->UnLock();
	print STDERR "Could not get current usage from adminctl library\n";
	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				    "Temporarily unavailable");
    }
    if ($curusage->{"nodes"}->{'project'} + scalar(@nodeids) >=
	$max_externalnodes) {
	$slice->UnLock();
	my $nodesleft = $max_externalnodes - $curusage->{"nodes"}->{'project'};
	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				    "Too many nodes; limited to $nodesleft");
    }

    # Nalloc might fail if the node gets picked up by someone else.
    if (@nodeids && !$impotent) {
	system("$NALLOC $pid $eid @nodeids");
	if (($? >> 8) < 0) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Allocation failure");
	    goto bad;
	}
	elsif (($? >> 8) > 0) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				     "Could not allocate node");
	    goto bad;
	}
	# In case the code below fails, before ticket is created.
	@dealloc = @nodeids;
    }
    #
    # Now deal with links for wildcarded nodes. We need to fill in the
    # node_uuid.
    #
    foreach my $linkname (keys(%{$rspec->{'link'}})) {
	my $linkref = $rspec->{'link'}->{$linkname};

	foreach my $ref (@{$linkref->{'linkendpoints'}}) {
	    my $node_uuid     = $ref->{'node_uuid'};
	    my $node_nickname = $ref->{'node_nickname'};
	    my $iface_name    = $ref->{'iface_name'};
	    my $node;

	    if ($node_uuid eq "*" && !defined($node_nickname)) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Need nickname for wildcarded link");
		goto bad;
	    }

	    # XXX No wildcarding for tunnels.
	    if (exists($linkref->{'link_type'}) &&
		$linkref->{'link_type'} eq "tunnel") {
		if ($node_uuid eq "*") {
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Tunnels cannot be wildcarded");
		    goto bad;
		}
		next;
	    }

	    #
	    # First map the node if its wildcarded.
 	    #
	    if ($node_uuid eq "*") {
		if (!exists($namemap{$node_nickname})) {
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					     "Could not map wildcarded link");
		    goto bad;
		}
		$node = $namemap{$node_nickname};
		$ref->{'node_uuid'} = $node->uuid();
	    }
	    elsif (!exists($uuidmap{$node_uuid})) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "Could not map link node");
		goto bad;
	    }
	    else {
		$node = $uuidmap{$node_uuid};
	    }

	    #
	    # Now do wildcarded interfaces.
	    #
	    if ($iface_name eq "*") {
		my @interfaces;
		if ($node->AllInterfaces(\@interfaces) != 0) {
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Could not get interfaces for $node");
		    goto bad;
		}
		foreach my $interface (@interfaces) {
		    next
			if (!defined($interface->switch_id()));
		    next
			if ($interface->role() ne "expt");

		    $ref->{'iface_name'} = $interface->iface();
		    last;
		}
	    }
	}
    }
    
    #
    # Create the ticket. 
    #
    my $ticket = GeniTicket->Create($slice, $user, $rspec);
    if (!defined($ticket)) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not create GeniTicket object");
	goto bad;
    }
    if ($ticket->Sign() != 0) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Could not sign Ticket");
	goto bad;
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $ticket->asString());
  bad:
    # Release will free the nodes.
    if (defined($ticket)) {
	$ticket->Release(TICKET_PURGED);
    }
    elsif (@dealloc) {
	system("export NORELOAD=1; $NFREE -x -q $pid $eid @dealloc");
    }
    $slice->UnLock()
	if (defined($slice));
    return $response;
}

#
# Create a sliver.
#
sub RedeemTicket($)
{
    my ($argref) = @_;
    my $ticket     = $argref->{'ticket'};
    my $impotent   = $argref->{'impotent'};
    my $keys       = $argref->{'keys'};
    my $extraargs  = $argref->{'extraargs'};

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

    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");
    }
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($ticket->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    my $slice = GeniSlice->Lookup($ticket->slice_uuid());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    #
    # Do not redeem an expired ticket, kill it now.
    #
    if ($ticket->Expired()) {
	$ticket->Release(TICKET_EXPIRED);
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_EXPIRED, undef,
				    "Ticket has expired");
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }

    #
    # For now, ther can be only a single toplevel aggregate per slice.
    #
    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (defined($aggregate)) {
	$ticket->Release(TICKET_EXPIRED);
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Already have an aggregate for slice");
    }
    my $response = ModifySliver(undef, $slice, $ticket,
				$ticket->rspec(), $impotent, $keys);
    $slice->UnLock();
    return $response;
}

#
# Update a sliver with a different resource set.
#
sub UpdateSliver($)
{
    my ($argref) = @_;
    my $cred        = $argref->{'credential'};
    my $rspec       = $argref->{'rspec'};
    my $impotent    = $argref->{'impotent'};
    my $keys        = $argref->{'keys'};
    my $extraargs   = $argref->{'extraargs'};

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

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    if (! (defined($rspec) && ($rspec =~ /^[-\w]+$/))) {
	GeniResponse->Create(GENIRESPONSE_BADARGS, undef, "Improper rspec");
    }
    $rspec = XMLin($rspec, ForceArray => ["node", "link", "linkendpoints"]);

    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $sliver_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid();

    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
    my $sliver = GeniSliver->Lookup($sliver_uuid);
    if (defined($sliver)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Only aggregates for now");
    }
    my $aggregate = GeniAggregate->Lookup($sliver_uuid);
    if (!defined($aggregate)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "No such aggregate $sliver_uuid");
    }
    my $slice = GeniSlice->Lookup($aggregate->slice_uuid());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }

    my $response = ModifySliver($aggregate, $slice,
				$credential, $rspec, $impotent, $keys);
    $slice->UnLock();
    return $response;
}

#
# Utility function for above routines.
#
sub ModifySliver($$$$$$)
{
    my ($object, $slice, $credential, $rspec, $impotent, $keys) = @_;

    my $owner_uuid = $credential->owner_uuid();
    my $message    = "Error creating sliver/aggregate";
    my $aggregate;
    
    #
    # Create the user.
    #
    my $owner = GeniUser->Lookup($owner_uuid);
    if (!defined($owner)) {
	$owner = CreateUserFromCertificate($credential->owner_cert());
	if (!defined($owner)) {
	    print STDERR "No user $owner_uuid in the ClearingHouse\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No user record for $owner_uuid");
	}
    }
    if (!$owner->IsLocal() && defined($keys)) {
	$owner->Modify(undef, undef, $keys);
    }

    my $experiment = GeniExperiment($slice);
    if (!defined($experiment)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local experiment for slice");
    }
    print STDERR Dumper($rspec);

    #
    # Figure out what nodes to allocate or free. 
    #
    my %nodelist = ();
    my %linklist = ();
    my %toalloc  = ();
    my @allocated= ();
    my @tofree   = ();
    my $pid      = $experiment->pid();
    my $eid      = $experiment->eid();
    my $needplabslice = 0;
    my $didfwsetup = 0;

    #
    # Find current nodes and record their uuids. 
    #
    if (defined($object)) {
	if ($object->type() ne "Aggregate") {
	    return GeniResponse->Create(GENIRESPONSE_UNSUPPORTED, undef,
					"Only node aggregates allowed");
	}
	my @slivers;
	if ($object->SliverList(\@slivers) != 0) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	}
	foreach my $s (@slivers) {
	    if (ref($s) eq "GeniSliver::Node") {
		$nodelist{$s->resource_uuid()} = $s;
	    }
	    elsif (ref($s) eq "GeniAggregate::Link" ||
		   ref($s) eq "GeniAggregate::Tunnel") {
		$linklist{$s->uuid()} = $s;
	    }
	    else {
		return GeniResponse->Create(GENIRESPONSE_UNSUPPORTED, undef,
					    "Only nodes or links allowed");
	    }
	}
    }

    #
    # Figure out new expiration time; this is the time at which we can
    # idleswap the slice out. 
    #
    if (exists($rspec->{'valid_until'})) {
	my $expires = $rspec->{'valid_until'};

	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");
	}
	#
	# No more then 24 hours out ... Needs to be a sitevar?
	#
	my $diff = $when - time();
	if ($diff < (60 * 15) || $diff > (3600 * 24)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"valid_until out of range");
	}
	if ($slice->SetExpiration($when) != 0) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not set expiration time");
	}
    }

    #
    # Figure out what nodes need to be allocated.
    #
    foreach my $ref (@{$rspec->{'node'}}) {
	my $resource_uuid = $ref->{'uuid'};
	my $node = Node->Lookup($resource_uuid);
	if (!defined($node)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Bad resource_uuid $resource_uuid");
	}

	#
	# Widearea nodes do not need to be allocated, but for now all
	# I allow is a plabdslice node.
	#
	if ($node->isremotenode()) {
	    if (! $node->isplabphysnode()) {
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					    "Only plab widearea nodes");
	    }
	    $needplabslice = 1;
	    next;
	}

	#
	# See if the node is already reserved. 
	#
	my $reservation = $node->Reservation();
	if (defined($reservation)) {
	    # Reserved during previous operation on the sliver.
	    next
		if ($reservation->SameExperiment($experiment));
	    
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				"$resource_uuid ($node) is not available");
	}
	#
	# Sanity check on the list of already allocated nodes.
	#
	foreach my $s (values(%nodelist)) {
	    if ($resource_uuid eq $s->resource_uuid()) {
		print STDERR
		    "$resource_uuid is not supposed to be allocated\n";
		return GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	    }
	}
	$toalloc{$resource_uuid} = $node->node_id();
    }

    #
    # What nodes need to be released?
    #
    foreach my $s (values(%nodelist)) {
	my $node_uuid = $s->resource_uuid();
	my $node      = Node->Lookup($node_uuid);
	my $needfree  = 1;
	
	foreach my $ref (@{$rspec->{'node'}}) {
	    my $resource_uuid = $ref->{'uuid'};
	    if ($node_uuid eq $resource_uuid) {
		$needfree = 0;
		last;
	    }
	}
	if ($needfree) {
	    #
	    # Not yet.
	    #
	    my @dlist;
	    if ($s->DependentSlivers(\@dlist) != 0) {
		return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					    "Could not get DependentSlivers");
	    }
	    if (@dlist) {
		return GeniResponse->Create(GENIRESPONSE_REFUSED, undef,
				    "Must tear down dependent slivers first");
	    }
	    push(@tofree, $s);
	}
    }

    #
    # Create an emulab nonlocal user for tmcd.
    #
    $owner->BindToSlice($slice) == 0
	or return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				       "Error binding user to slice");


    # Bind the other users too.
    # XXX Need to figure out where these come from.
    my @userbindings = ();

    foreach my $otheruuid (@userbindings) {
	my $otheruser = GeniUser->Lookup($otheruuid);
	if (!defined($otheruser)) {
	    $otheruser = CreateUserFromCertificate($otheruuid);
	    if (!defined($otheruser)) {
		print STDERR "No user $otheruser, cannot bind to slice\n";
		next;
	    }
	}
	if ($otheruser->BindToSlice($slice) != 0) {
	    print STDERR "Could not bind $otheruser to $slice\n";
	}
    }

    #
    # We are actually an Aggregate, so return an aggregate of slivers,
    # even if there is just one node. This makes sliceupdate easier.
    #
    if (defined($object)) {
	$aggregate = $object;
    }
    else {
	#
	# Form the hrn from the slicename.
	#
	my $hrn = "${OURDOMAIN}." . $slice->slicename();
	
	$aggregate = GeniAggregate->Create($slice, $owner, "Aggregate",
					   $hrn, $slice->hrn());
	if (!defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not create GeniAggregate object");
	}
    }

    # Nalloc might fail if the node gets picked up by someone else.
    if (values(%toalloc) && !$impotent) {
	my @list = values(%toalloc);
	system("$NALLOC $pid $eid @list");
	if ($?) {
	    # Nothing to deallocate if this fails.
	    %toalloc = undef;
	    $message = "Allocation failure";
	    goto bad;
	}
    }

    #
    # We need to tear down links that are no longer in the rspec or
    # have changed.
    #
    foreach my $s (values(%linklist)) {
	if (! exists($rspec->{'link'}->{$s->hrn()})) {
	    $s->UnProvision();
	    $s->Delete(0);
	    next;
	}

	my $delete     = 0;
	my @interfaces = ();
	if ($s->SliverList(\@interfaces) != 0) {
	    $message = "Failed to get sliverlist for $s";
	    goto bad;
	}
	foreach my $i (@interfaces) {
	    my $node_uuid   = $i->resource_uuid();
	    my $iface_name  = $i->rspec()->{'iface_name'};

	    my $linkendpoints =
		$rspec->{'link'}->{$s->hrn()}->{'linkendpoints'};
	}
    }
    
    #
    # Now for each resource (okay, node) in the ticket create a sliver and
    # add it to the aggregate.
    #
    my %slivers   = ();
    my @plabnodes = ();
    foreach my $ref (@{$rspec->{'node'}}) {
	my $resource_uuid = $ref->{'uuid'};
	# Already in the aggregate?
	next
	    if (grep {$_ eq $resource_uuid} keys(%nodelist));
	
	my $node = Node->Lookup($resource_uuid);
	if (!defined($node)) {
	    $message = "Unknown resource_uuid in ticket: $resource_uuid";
	    goto bad;
	}
	my $sliver = GeniSliver::Node->Create($slice,
					      $owner,
					      $resource_uuid,
					      $ref);
	if (!defined($sliver)) {
	    $message = "Could not create GeniSliver object for $resource_uuid";
	    goto bad;
	}
	$slivers{$resource_uuid} = $sliver;

	#
	# Remove this from %toalloc; if there is an error, the slivers are
	# deleted and the node released there. We only delete nodes that
	# have not turned into slivers yet. Ick.
	#
	delete($toalloc{$resource_uuid});

	# Used below.
	push(@allocated, $node);

	# See below; setup all pnodes at once.
	if ($node->isremotenode()) {
	    my $vnode = Node->Lookup($sliver->uuid());
	    if (!defined($vnode)) {
		print STDERR "Could not locate vnode $sliver\n";
		goto bad;
	    }
	    push(@plabnodes, $vnode);
	}
    }

    #
    # 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.
    #
    goto skiplinks
	if (!exists($rspec->{'link'}));
    
    foreach my $linkname (keys(%{$rspec->{'link'}})) {
	my @linkslivers  = ();
	if (! ($linkname =~ /^[-\w]*$/)) {
	    $message = "Bad name for link: $linkname";
	    goto bad;
	}
	my $linkref = $rspec->{'link'}->{$linkname};

	#
	# XXX Tunnels are a total kludge right now ...
	#
	if (exists($linkref->{'link_type'}) &&
	    $linkref->{'link_type'} eq "tunnel") {

	    my $node1ref = (@{$linkref->{'linkendpoints'}})[0];
	    my $node2ref = (@{$linkref->{'linkendpoints'}})[1];

	    my $node1sliver = $slivers{$node1ref->{'node_uuid'}} ||
		$nodelist{$node1ref->{'node_uuid'}};
	    my $node2sliver = $slivers{$node2ref->{'node_uuid'}} ||
		$nodelist{$node2ref->{'node_uuid'}};
	    
	    my $tunnel = GeniAggregate::Tunnel->Create($slice,
						       $owner,
						       $node1sliver,
						       $node2sliver,
						       $linkref);

	    if (!defined($tunnel)) {
		$message = "Could not create tunnel aggregate for $linkname";
		goto bad;
	    }
	    $slivers{$tunnel->uuid()} = $tunnel;
	    next;
	}

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

	foreach my $ref (@{$rspec->{'link'}->{$linkname}->{'linkendpoints'}}) {
	    my $node_uuid  = $ref->{'node_uuid'};
	    my $iface_name = $ref->{'iface_name'};
	    my $nodesliver = $slivers{$node_uuid} || $nodelist{$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_name);
	    if (!defined($interface)) {
		$message = "No such interface $iface_name on node $nodeobject";
		goto bad;
	    }
	    my $sliver = GeniSliver::Interface->Create($slice,
						       $owner,
						       $interface->uuid(),
						       $nodeobject,
						       $ref);
	    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;
	    }
	}
    }
  skiplinks:
    #
    # Create a planetlab slice before provisioning (which creates nodes).
    #
    if ($needplabslice && !$impotent) {
	system("$PLABSLICE create $pid $eid");
	if ($?) {
	    $message = "Plab Slice creation failure";
	    goto bad;
	}
    }

    #
    # Now do the provisioning (note that we actually allocated the
    # node above when the ticket was granted). Then add the sliver to
    # the aggregate. 
    #
    foreach my $sliver (values(%slivers)) {
	if (!$impotent && $sliver->Provision() != 0) {
	    $message = "Could not provision $sliver";
	    goto bad;

	}
	if ($sliver->SetAggregate($aggregate) != 0) {
	    $message = "Could not set aggregate for $sliver to $aggregate";
	    goto bad;
	}
    }

    #
    # We want to do this stuff only once, not for each node. 
    #
    # Must have the topofile for node boot. Might need locking on this.
    if (system("$GENTOPOFILE $pid $eid")) {
	print STDERR "$GENTOPOFILE failed\n";
	goto bad;
    }
    # The nodes will not boot locally unless there is a DNS record.
    if (system("$NAMEDSETUP")) {
	print STDERR "$NAMEDSETUP failed\n";
	goto bad;
    }
    # Do firewall stuff.
    if ($slice->needsfirewall()) {
	my $experiment = $slice->GetExperiment();
	my @node_ids = map { $_->node_id() } @allocated;
	
	if (@node_ids && doFWlans($experiment, FWADDNODES, \@node_ids) != 0) {
	    print STDERR "FireWall setup failed\n";
	    goto bad;
	}
	$didfwsetup = 1;
    }
    # Set up plab nodes all at once. 
    if ($needplabslice && @plabnodes && !$impotent) {
	my @node_ids = map { $_->node_id() } @plabnodes;

	system("$VNODESETUP -p -q -m $pid $eid @node_ids");
	if ($?) {
	    print STDERR "$VNODESETUP failed\n";
	    goto bad;
	}
    }

    #
    # The API states we return a credential to control the aggregate.
    #
    if (ref($credential) eq "GeniTicket") {
	my $ticket  = $credential;
	$credential = $aggregate->NewCredential($owner);
	if (!defined($credential)) {
	    $message = "Could not create credential";
	    goto bad;
	}
    
	#
	# The last step is to delete the ticket, since it is no longer needed.
	# and will cause less confusion if it is not in the DB.
	#
	if ($ticket->Delete(TICKET_REDEEMED) != 0) {
	    print STDERR "Error deleting $ticket for $slice\n";
	}
	return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				    $credential->asString());
    }
    #
    # Free any slivers that were no longer wanted.
    #
    if (@tofree) {

    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);

  bad:
    # Do firewall stuff.
    if ($slice->needsfirewall() && $didfwsetup) {
	my $experiment = $slice->GetExperiment();
	my @node_ids = map { $_->node_id() } @allocated;
	
	if (@node_ids && doFWlans($experiment, FWDELNODES, \@node_ids) != 0) {
	    print STDERR "FireWall cleanup failed\n";
	}
    }
    foreach my $sliver (values(%slivers)) {
	$sliver->UnProvision()
	    if (! $impotent);
	$sliver->Delete(1);
    }
    if (values(%toalloc)) {
	my @list = values(%toalloc);

	system("export NORELOAD=1; $NFREE -x -q $pid $eid @list");
    }
    $aggregate->Delete(1)
	if (defined($aggregate) && !defined($object));
    
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef, $message);
}

#
# Release a ticket.
#
sub ReleaseTicket($)
{
    my ($argref) = @_;
    my $ticket     = $argref->{'ticket'};

    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");
    }
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($ticket->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    #
    # Lock the slice to avoid concurrent operation.
    #
    my $slice = GeniSlice->Lookup($ticket->slice_uuid());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    if ($ticket->Release(TICKET_RELEASED) != 0) {
	print STDERR "Error releasing $ticket\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Start a sliver (not sure what this means yet, so reboot for now).
#
sub StartSliver($)
{
    my ($argref) = @_;
    my $cred        = $argref->{'credential'};
    my $impotent    = $argref->{'impotent'};

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

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $sliver_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
    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");
	}
    }
    #
    # Lock the slice to avoid concurrent operation.
    #
    my $slice = GeniSlice->Lookup($sliver->slice_uuid());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }
    if (!$impotent && $sliver->Start() != 0) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start sliver/aggregate");
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Destroy a sliver/aggregate.
#
sub DeleteSliver($)
{
    my ($argref) = @_;
    my $cred        = $argref->{'credential'};
    my $impotent    = $argref->{'impotent'};
    my $response;

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

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $sliver_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    #
    # For now, only allow top level aggregate to be deleted.
    #
    my $aggregate = GeniAggregate->Lookup($sliver_uuid);
    if (!defined($aggregate)) {
	my $sliver = GeniSliver->Lookup($sliver_uuid);
	if (defined($sliver)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Must supply toplevel sliver");
	}
	else {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"No such sliver");
	}
    }
    elsif ($aggregate->type() ne "Aggregate") {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Must supply toplevel sliver");
    }
    my $slice_uuid = $aggregate->slice_uuid();
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }

    if (!$impotent) {
	#
	# A firewalled slice gets special treatment.
	#
	if ($slice->needsfirewall()) {
	    my $experiment = $slice->GetExperiment();
	
	    if (undoFWNodes($experiment, 1) != 0) {
		print STDERR "FireWall cleanup failed\n";
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Could not tear down firewall");
		goto bad;
	    }
	}
	if ($aggregate->UnProvision() != 0) {
	    $response = 
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Could not unprovision sliver");
	    goto bad;
	}
	if ($aggregate->Delete(0) != 0) {
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					     "Could not delete sliver");
	    goto bad;
	}
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);

  bad:
    return $response;
}

#
# Remove a record, specifically a slice on this component.
#
sub DeleteSlice($)
{
    my ($argref) = @_;
    my $credential = $argref->{'credential'};

    if (! defined($credential)) {
	return GeniResponse->MalformedArgsResponse();
    }

    $credential = GeniCredential->CreateFromSigned($credential);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }

    my $slice_uuid = $credential->target_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    #
    # 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)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			    "No such slice on this component: $slice_uuid");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    if (CleanupDeadSlice($slice) != 0) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not cleanup slice");
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Split an aggregated sliver into its separate parts and return a list.
#
sub SplitSliver($)
{
    my ($argref) = @_;
    my $cred        = $argref->{'credential'};
    my $impotent    = $argref->{'impotent'};

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

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $sliver_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
    my $user = GeniUser->Lookup($user_uuid);
    if (!defined($user)) {
	$user = CreateUserFromCertificate($credential->owner_cert());
	if (!defined($user)) {
	    print STDERR "No user $user_uuid in the ClearingHouse\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No user record for $user_uuid");
	}
    }

    my $aggregate = GeniAggregate->Lookup($sliver_uuid);
    if (!defined($aggregate)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "No such aggregate $sliver_uuid");
    }
    my $slice = GeniSlice->Lookup($aggregate->slice_uuid());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			    "No such slice on this component");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    
    my @sliver_list = ();
    if ($aggregate->SliverList(\@sliver_list) != 0) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not get slivers for $aggregate");
    }
    my @credentials = ();

    foreach my $sliver (@sliver_list) {
	my $credential = $sliver->NewCredential($user);
	if (!defined($credential)) {
	    $slice->UnLock();
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not create credential for $sliver");
	}
	push(@credentials, $credential->asString());
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@credentials);
}

#
# Return the top level aggregate (sliver) for a slice. 
#
sub GetSliver($)
{
    my ($argref) = @_;
    my $cred     = $argref->{'credential'};

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }

    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();

    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
    my $user = GeniUser->Lookup($user_uuid);
    if (!defined($user)) {
	$user = CreateUserFromCertificate($credential->owner_cert());
	if (!defined($user)) {
	    print STDERR "Could not create user from certificate\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
    }

    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }

    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (!defined($aggregate)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No slivers here for slice");
    }
    
    my $new_credential = $aggregate->NewCredential($user);
    if (!defined($new_credential)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				$new_credential->asString());
}

#
# Bind additional user to a slice, including keys. This is allowed because
# the user has a slice credential, which came from the SA for the slice.
# Note that this call can also be used to update your keys.
#
sub BindToSlice($)
{
    my ($argref) = @_;
    my $cred     = $argref->{'credential'};
    my $keys     = $argref->{'keys'};

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }

    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();

    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "Slice does not exist here");
    }
    
    #
    # Find or create the user.
    #
    my $user = GeniUser->Lookup($user_uuid);
    if (!defined($user)) {
	$user = CreateUserFromCertificate($credential->owner_cert());
	if (!defined($user)) {
	    print STDERR "Could not create user from certificate\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create/find user");
	}
    }
    if (!$user->IsLocal() && defined($keys)) {
	$user->Modify(undef, undef, $keys);
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    # Bind for future slivers.
    if ($slice->BindUser($user) != 0) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Error binding slice to user");
    }
    # Bind for existing slivers. 
    if ($user->BindToSlice($slice) != 0) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Error binding user to slice");
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Shutdown a slice. This is brutal at present; kill it completely.
#
sub Shutdown($)
{
    my ($argref) = @_;
    my $cred  = $argref->{'credential'};
    my $clear = $argref->{'clear'};

    if (! (defined($cred))) {
	return GeniResponse->MalformedArgsResponse();
    }
    $clear = (defined($clear) ? $clear : 0);
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    #
    # Create the slice record, since we do not want a request to come
    # in later.
    #
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	$slice = CreateSliceFromCertificate($credential);
	if (!defined($slice)) {
	    print STDERR "Could not create $slice_uuid\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create slice");
	}
	# No point in doing anything else ...
	$slice->SetShutdown(1);
	return GeniResponse->Create(GENIRESPONSE_SUCCESS);
    }
    #
    # Do not worry about locking when setting the shutdown time.
    # This can lead to race though, if a clear shutdown comes in first.
    # Seems unlikely though. 
    #
    if (!$clear) {
	# Do not overwrite original shutdown time
	$slice->SetShutdown(1)
	    if (!defined($slice->shutdown()) || $slice->shutdown() eq "");
    }
    else {
	$slice->SetShutdown(0);
    }
    # Always make sure the slice is shutdown.
    if ($slice->shutdown()) {
	# The expire daemon is going to look for this, so it will get
	# taken care of shortly.
	if ($slice->Lock() != 0) {
	    return GeniResponse->BusyResponse();
	}
	if (CleanupDeadSlice($slice, 0) != 0) {
	    SENDMAIL($TBOPS, "Failed to shutdown slice",
		     "Failed to shutdown slice $slice\n");
	    print STDERR "Could not shutdown $slice!\n";
	    # Lets call this a non-error since the local admin person
	    # is going to have to deal with it anyway. 
	}
	$slice->UnLock();
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Return a list of resources currently in use.
# This is used by the clearinghouse to get a global sense of usage.
# Currently, only the ClearingHouse will be allowed to make this call,
# but eventually I think it should be opened up to any of federation
# roots
#
sub ListUsage($)
{
    my ($argref) = @_;
    my $cred     = $argref->{'credential'};

    if (! (defined($cred))) {
	return GeniResponse->MalformedArgsResponse();
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }
    #
    # And that the target of the credential is this registry.
    #
    if ($credential->target_uuid() ne $ENV{'MYUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN,
				    undef, "This is not your authority!");
    }
    # Just one of these, at Utah.
    my $GENICH_PEMFILE = "@prefix@/etc/genich.pem";
    my $certificate = GeniCertificate->LoadFromFile($GENICH_PEMFILE);
    if (!defined($certificate)) {
	print STDERR "Could not load certificate from $GENICH_PEMFILE\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

    # The caller has to match the clearinghouse.
    if ($credential->owner_uuid() ne $certificate->uuid()) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Only the clearinghouse can do this!");
    }
    my @slices;
    if (GeniSlice->ListAll(\@slices) != 0) {
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    my @result = ();

    foreach my $slice (@slices) {
	#
	# Grab all the slivers for this slice, and then
	# look for just the nodes.
	#
	my @slivers    = ();
	my @components = ();
	if (GeniSliver->SliceSlivers($slice, \@slivers) != 0) {
	    print STDERR "Could not slice slivers for $slice\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	foreach my $sliver (@slivers) {
	    next
		if ($sliver->resource_type() ne "Node");

	    my $node = {"sliver_gid"    => $sliver->cert(),
			"sliver_hrn"    => $sliver->hrn() };
	    
	    my $component = GeniComponent->Lookup($sliver->resource_uuid());
	    if (defined($component)) {
		$node->{"component_gid"} = $component->cert();
		$node->{"component_hrn"} = $component->hrn();
	    }
	    else {
		print STDERR "No component in DB for resource ".
		    $sliver->resource_uuid() . "\n";
	    }
	    push(@components, $node);
	}
	next
	    if (!@components);
	
	my $blob = {"slice_gid"  => $slice->cert(),
		    "slice_hrn"  => $slice->hrn(),
		    "slivers"    => \@components };

	push(@result, $blob);
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@result);
}

#
# Slice Status
#
sub SliceStatus($)
{
    my ($argref) = @_;
    my $cred  = $argref->{'credential'};
    my $mode  = $argref->{'mode'};
    $mode = "summary"
	if (!defined($mode));

    if (! (defined($cred))) {
	return GeniResponse->MalformedArgsResponse();
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No such slice here");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (!defined($aggregate)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No slivers here for slice");
    }
    #
    # Grab all the slivers for this slice, and then
    # look for just the nodes.
    #
    my $summary    = "ready";
    my %details    = ();
    my @slivers    = ();
    if (GeniSliver->SliceSlivers($slice, \@slivers) != 0) {
	print STDERR "Could not get slivers for $slice\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    foreach my $sliver (@slivers) {
	next
	    if ($sliver->resource_type() ne "Node");

	my $node_uuid = $sliver->resource_uuid();
	my $node = Node->Lookup($node_uuid);
	if (!defined($node)) {
	    $slice->UnLock();
	    print STDERR "Cannot find node by uuid $node_uuid\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	if ($node->IsUp()) {
	    $details{$node_uuid} = "ready";
	}
	else {
	    $details{$node_uuid} = "notready";
	    $summary = "notready";
	}
    }
    $slice->UnLock();
    my $blob = {"status"  => $summary,
		"details" => \%details};
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
}

#
# Sliver status.
#
sub SliverStatus($)
{
    my ($argref) = @_;
    my $cred        = $argref->{'credential'};

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($cred);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    my $sliver_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid();
    
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your credential!");
    }

    #
    # For now, only allow top level aggregate to be deleted.
    #
    my $aggregate = GeniAggregate->Lookup($sliver_uuid);
    if (!defined($aggregate)) {
	my $sliver = GeniSliver->Lookup($sliver_uuid);
	if (defined($sliver)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Must supply toplevel sliver");
	}
	else {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"No such sliver");
	}
    }
    elsif ($aggregate->type() ne "Aggregate") {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Must supply toplevel sliver");
    }
    my $slice_uuid = $aggregate->slice_uuid();
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }

    #
    # Grab all the slivers for this slice, and then
    # look for just the nodes.
    #
    my $summary    = "ready";
    my %details    = ();
    my @slivers    = ();
    if ($aggregate->SliverList(\@slivers) != 0) {
	print STDERR "Could not get slivers for $aggregate\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    foreach my $sliver (@slivers) {
	next
	    if ($sliver->isa("GeniAggregate"));
	next
	    if ($sliver->resource_type() ne "Node");

	my $node_uuid = $sliver->resource_uuid();
	my $node = Node->Lookup($node_uuid);
	if (!defined($node)) {
	    $slice->UnLock();
	    print STDERR "Cannot find node by uuid $node_uuid\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	if ($node->IsUp()) {
	    $details{$node_uuid} = "ready";
	}
	else {
	    $details{$node_uuid} = "notready";
	    $summary = "notready";
	}
    }
    $slice->UnLock();
    my $blob = {"status"  => $summary,
		"details" => \%details};
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
}

#
# Utility Routines.
#
# Create a slice from the a certificate (GID).
#
sub CreateSliceFromCertificate($)
{
    my ($credential) = @_;

    my $certificate = $credential->target_cert();
    my $owner_uuid  = $credential->owner_uuid();

    my $authority = GeniAuthority->LookupByPrefix($certificate->uuid());
    if (!defined($authority)) {
	$authority = CreateAuthorityFromRegistry($certificate->uuid());
	if (!defined($authority)) {
	    print STDERR "Could not create new authority record\n";
	    return undef;
	}
    }

    #
    # The problem with HRNs is that people will tend to reuse them.
    # So check to see if we have a slice with the hrn, and if so
    # we need to check with the registry to see if its still active.
    # Destroy it locally if not active.
    #
    my $slice = GeniSlice->Lookup($certificate->hrn());
    if (defined($slice)) {
	return $slice
	    if ($slice->uuid() eq $certificate->uuid());

	if ($slice->Lock() != 0) {
	    print STDERR "Could not lock $slice\n";
	    return undef;
	}
	if (CleanupDeadSlice($slice) != 0) {
	    print STDERR "Could not cleanup dead slice $slice\n";
	    $slice->UnLock();
	    return undef;
	}
    }
    $slice = GeniSlice->Create($certificate, $owner_uuid, $authority);
    return undef
	if (!defined($slice));

    return $slice;
}

#
# Create a user from a certificate.
#
sub CreateUserFromCertificate($)
{
    my ($certificate) = @_;

    #
    # Check Emulab users table first.
    #
    my $user = User->LookupByUUID($certificate->uuid());
    if (defined($user)) {
	my $geniuser = GeniUser->CreateFromLocal($user);
	if (!defined($geniuser)) {
	    print STDERR "Could not create geniuser from $user\n";
	    return undef;
	}
	return $geniuser;
    }

    my $authority = GeniAuthority->LookupByPrefix($certificate->uuid());
    if (!defined($authority)) {
	$authority = CreateAuthorityFromRegistry($certificate->uuid());
	if (!defined($authority)) {
	    print STDERR "Could not create new authority record\n";
	    return undef;
	}
    }

    return GeniUser->Create($certificate, $authority);
}

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

    my ($prefix) = ($uuid =~ /^\w+\-\w+\-\w+\-\w+\-(\w+)$/);

    my $clearinghouse = GeniRegistry::ClearingHouse->Create();
    return undef
	if (!defined($clearinghouse));

    my $blob;
    return undef
	if ($clearinghouse->Resolve("P${prefix}", "SA", \$blob) != 0);

    my $certificate = GeniCertificate->LoadFromString($blob->{'gid'});
    return undef
	if (!defined($certificate));

    my $authority = GeniAuthority->Create($certificate,
					  $blob->{'url'},
					  $blob->{'type'});
    $certificate->Delete()
	if (!defined($authority));

    return $authority;
}

#
# Cleanup a dead slice, releasing all the stuff associated with it.
#
sub CleanupDeadSlice($;$)
{
    my ($slice, $purge) = @_;

    # Default to full purge.
    $purge = 1
	if (!defined($purge));

    # print "Cleaning up dead slice $slice\n";

    #
    # A firewalled slice gets special treatment.
    #
    if ($slice->needsfirewall()) {
	my $experiment = $slice->GetExperiment();

	print "Calling undoFWNodes ...\n";
	
	if (undoFWNodes($experiment) != 0) {
	    print STDERR "FireWall cleanup failed\n";
	    return -1;
	}
    }

    #
    # Find any aggregates and tear them down.
    #
    my @aggregates;
    if (GeniAggregate->SliceAggregates($slice, \@aggregates) != 0) {
	print STDERR "Could not get dead aggregates for $slice.\n";
	return -1;
    }
    #
    # Link aggregates first.
    #
    my @nonlinks = ();
    
    foreach my $aggregate (@aggregates) {
	if (! ($aggregate->type() eq "Link" ||
	       $aggregate->type() eq "Tunnel")) {
	    push(@nonlinks, $aggregate);
	    next;
	}
	if ($aggregate->UnProvision() != 0) {
	    print STDERR "Could not UnProvision $aggregate\n";
	    return -1;
	}
	if ($aggregate->Delete(0) != 0) {
	    print STDERR "Could not delete $aggregate\n";
	    return -1;
	}
    }
    foreach my $aggregate (@nonlinks) {
	if ($aggregate->UnProvision() != 0) {
	    print STDERR "Could not UnProvision $aggregate\n";
	    return -1;
	}
	if ($aggregate->Delete(0) != 0) {
	    print STDERR "Could not delete $aggregate\n";
	    return -1;
	}
    }

    #
    # Are there any slivers left after killing the aggregates? 
    #
    my @slivers;
    if (GeniSliver->SliceSlivers($slice, \@slivers) != 0) {
	print STDERR "Could not get dead slivers for $slice.\n";
	return -1;
    }
    foreach my $sliver (@slivers) {
	if ($sliver->UnProvision() != 0) {
	    print STDERR "Could not UnProvision $sliver\n";
	    return -1;
	}
	if ($sliver->Delete(0) != 0) {
	    print STDERR "Could not delete $sliver\n";
	    return -1;
	}
    }

    #
    # And lastly, any tickets that were not instantiated. 
    #
    my @tickets;
    if (GeniTicket->SliceTickets($slice, \@tickets) != 0) {
	print STDERR "Could not get dead tickets for $slice.\n";
	return -1;
    }
    foreach my $ticket (@tickets) {
	# print STDERR "Releasing $ticket\n";
	
	if ($ticket->Release(TICKET_EXPIRED) != 0) {
	    print STDERR "Could not delete $ticket\n";
	    return -1;
	}
    }

    return 0
	if (!$purge);

    my $experiment = $slice->GetExperiment();
    if (defined($experiment)) {
	$experiment->LockDown(0);
	
	my $pid = $experiment->pid();
	my $eid = $experiment->eid();
	system("$PLABSLICE destroy $pid $eid");
    
	system("$ENDEXPT -q $pid,$eid");
	return -1
	    if ($?);
	$experiment->Flush();
    }
    
    if ($slice->Delete() != 0) {
	print STDERR "Could not delete $slice\n";
	return -1;
    }
    return 0;
}

#
# 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.
#
sub GeniExperiment($)
{
    my ($slice) = @_;

    my $uuid = $slice->uuid();
    my $needsfirewall = $slice->needsfirewall();

    my $experiment = Experiment->Lookup($uuid);
    if (!defined($experiment)) {
	#
	# Form an eid for the experiment. 
	#
	my $eid    = "slice" . TBGetUniqueIndex('next_sliceid', 1);
	my $nsfile = "";

	#
	# Need a way to can experiments.
	#
	if ($needsfirewall) {
	    $nsfile = "/tmp/$$.ns";
	    open(NS, "> $nsfile")
 		or return undef;
	    print NS "source tb_compat.tcl\n";
	    print NS "set ns [new Simulator]\n";
	    print NS "tb-set-security-level Yellow\n";
	    print NS "\$ns run\n";
	    close(NS);
	}

	# Note the -h option; allows experiment with no NS file.
	system("$CREATEEXPT -q -i -k -w ".
	       "-S 'Geni Slice Experiment -- DO NOT SWAP OR TERMINATE' ".
	       "-E 'Geni Slice Experiment -- DO NOT SWAP OR TERMINATE' ".
	       "-L 'Geni Slice Experiment -- DO NOT SWAP OR TERMINATE' ".
	       "-h '$uuid' -p GeniSlices -e $eid $nsfile");
	if ($?) {
	    return undef;
	}
	$experiment = Experiment->Lookup($uuid);
	$experiment->Update({"geniflags" => 1});
    }
    return $experiment;
}

#
#
#
sub FindFreeNode($@)
{
    # Already going to allocate these.
    my $vtype   = shift(@_);
    my $type    = "pc";
    my @nodeids = @_;

    if (defined($vtype)) {
	# XXX Need to implement this.
	;
    }
    
    my $query_result =
	DBQueryWarn("select uuid from geni_components");
    return undef
	if (!$query_result || !$query_result->numrows);

    while (my ($uuid) = $query_result->fetchrow_array()) {
	my $node = Node->Lookup($uuid);
	next
	    if (!defined($node));
	next
	    if ($node->isremotenode());
	next
	    if (grep {$_ eq $node->node_id()} @nodeids);

	#
	# See if the node is already reserved.
	#
	my $reservation = $node->Reservation();
	return $node
	    if (!defined($reservation));
    }
    return undef;
}

# _Always_ make sure that this 1 is at the end of the file...
1;