#!/usr/bin/perl -wT
#
# GENIPUBLIC-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 GeniUtil;
use GeniHRN;
use libtestbed qw(SENDMAIL);
use emutil;
# Hate to import all this crap; need a utility library.
use libdb qw(TBGetSiteVar EXPTSTATE_SWAPPED EXPTSTATE_ACTIVE TBOPSPID
	     TBDB_NODESTATE_TBFAILED);
use User;
use Node;
use OSinfo;
use Image;
use Interface;
use English;
use Data::Dumper;
use XML::Simple;
use Date::Parse;
use POSIX qw(strftime tmpnam);
use Time::Local;
use Experiment;
use VirtExperiment;
use Firewall;
use Compress::Zlib;
use MIME::Base64;

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
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 $EXPORTS_SETUP  = "$TB/sbin/exports_setup";
my $VNODESETUP     = "$TB/sbin/vnode_setup";
my $GENTOPOFILE    = "$TB/libexec/gentopofile";
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
my $SNMPIT         = "$TB/bin/snmpit";
my $PRERENDER      = "$TB/libexec/vis/prerender";
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";

my $API_VERSION = 1;

#
# Tell the client what API revision we support.  The correspondence
# between revision numbers and API features is to be specified elsewhere.
# No credentials are required.
#
sub GetVersion()
{
    return GeniResponse->Create( GENIRESPONSE_SUCCESS, $API_VERSION );
}

# Look up a node by an identifier of unspecified type (perhaps a URN, an
# (obsolete) UUID, or an old-style HRN.  Ultimately, all IDs should be
# URNs and this mess will go away, but for now we try not to make
# any assumptions, because of backward compatibility constraints.
sub LookupNode($)
{
    my ($nodeid) = @_;

    if( GeniHRN::IsValid( $nodeid ) ) {
	# Looks like a URN.
	my ($auth,$t,$id) = GeniHRN::Parse( $nodeid );

	return undef if $auth ne $OURDOMAIN or $t ne "node";

	return Node->Lookup( $id );
    }
 
    #
    # Looks like an old HRN, but we only want the last token for node lookup.
    #
    if ($nodeid =~ /\./) {
	($nodeid) = ($nodeid =~ /\.([-\w]*)$/);

	return Node->Lookup($nodeid);
    }
    
    # Assume it's a UUID, and pass it on as is.
    return Node->Lookup($nodeid);
}

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

    if (! defined($cred)) {
	return GeniResponse->MalformedArgsResponse();
    }
    if (defined($uuid) && GeniHRN::IsValid($uuid)) {
	$hrn  = $uuid;
	$uuid = undef;
    }
    if( defined( $hrn ) && GeniHRN::IsValid( $hrn ) ) {
	my ($auth,$t,$id) = GeniHRN::Parse( $hrn );

	return GeniResponse->Create( GENIRESPONSE_ERROR, undef,
				     "Authority mismatch" )
	    if( $auth ne $OURDOMAIN );

	$type = lc( $t );
	
	$hrn = $id;	
    }
    if (! (defined($type) && ($type =~ /^(node)$/))) {
	return GeniResponse->MalformedArgsResponse();
    }
    # Allow lookup by uuid or hrn.
    if (! defined($uuid) && !defined( $hrn ) ) {
	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= LookupNode($uuid);
	}
	else {
	    $node= LookupNode($hrn);
	}
	if (! defined($node)) {
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}

	my $rspec = GetAdvertisement(0, $node->node_id());
	if (! defined($rspec)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not start avail");
	}
	
	# Return a blob.
	my $blob = { "hrn"          => "${PGENIDOMAIN}." . $node->node_id(),
		     "uuid"         => $node->uuid(),
		     "role"	    => $node->role(),
		     "hostname"     => $node->node_id() . ".${OURDOMAIN}",
		     "physctrl"     => 
			 Interface->LookupControl( $node->phys_nodeid() )->IP(),
		     "urn"          => GeniHRN::Generate( $OURDOMAIN,
							  "node",
							  $node->node_id() ),
		     "rspec"        => $rspec
		   };

	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 $available = $argref->{'available'} || 0;
    my $compress = $argref->{'compress'} || 0;
    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");
    }
    return DiscoverResourcesAux($available, $compress);
}
# Helper function for V2.
sub DiscoverResourcesAux($$)
{
    my ($available, $compress) = @_;
    my $user_uuid  = $ENV{'GENIUSER'};

    # Oh, for $*%(s sake.  Frontier::RPC2 insists on representing a
    # Boolean as its own object type -- which Perl always interprets as
    # true, regardless of the object's value.  Undo all of that silliness.
    if (defined($available) && ref($available) eq 'Frontier::RPC2::Boolean') {
	$available = $available->value;
    }
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }

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

    #
    # Acquire the advertisement from ptopgen and compress it if requested.
    #
    my $xml = GetAdvertisement($available, undef);
    if (! defined($xml)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start avail");
    }

    if( $compress ) {
	my $coder = Frontier::RPC2->new();
	my $base64 = encode_base64( compress( $xml ) );
	$xml = $coder->base64( $base64 );	
    }

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

#
# Use ptopgen in xml mode to spit back an xml file. 
#
sub GetAdvertisement($$)
{
    my ($available, $pc) = @_;
    my $xml = undef;

    my $invocation = "$PTOPGEN -x -g -r -a -p GeniSlices";
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
    if (open(AVAIL, "$invocation |")) {
	$xml = "";
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
    return $xml;
}

#
# Update a ticket with a new rspec.
#
sub UpdateTicket($)
{
    my ($argref) = @_;

    return GetTicket($argref, 1);
}

#
# Respond to a GetTicket request. 
#
sub GetTicket($;$)
{
    my ($argref, $isupdate) = @_;
    my $rspecstr   = $argref->{'rspec'};
    my $impotent   = $argref->{'impotent'};
    my $credstr    = $argref->{'credential'};
    my $tickstr    = $argref->{'ticket'};
    my $ticket;

    # Default to no update
    $isupdate = 0
	if (!defined($isupdate));
    $impotent = 0
	if (!defined($impotent));

    if (! defined($credstr)) {
	return GeniResponse->MalformedArgsResponse();
    }
    if (!defined($rspecstr)) {
	return GeniResponse->MalformedArgsResponse();
    }
    if (! ($rspecstr =~ /^[\040-\176\012\015\011]+$/)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper characters in rspec");
    }
    my $credential = GeniCredential->CreateFromSigned($credstr);
    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!");
    }
    if ($isupdate) {
	$ticket = GeniTicket->CreateFromSignedTicket($tickstr);
	if (!defined($ticket)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not create GeniTicket object");
	}
	$ticket->SetSlice($credential->target_uuid());
    }
    return GetTicketAux($credential,
			$rspecstr, $isupdate, $impotent, 0, 1, $ticket);
}

sub GetTicketAux($$$$$$$)
{
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level,
	$ticket) = @_;
    
    defined($credential) &&
	($credential->HasPrivilege( "pi" ) or
	 $credential->HasPrivilege( "instantiate" ) or
	 $credential->HasPrivilege( "bind" ) or
	 return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				      "Insufficient privilege" ));
    
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();
    
    #
    # Create slice from the certificate.
    #
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	if ($isupdate) {
	    print STDERR "Could not locate slice $slice_uuid for Update\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice found for UpdateTicket");
	}
	$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, 1);
    if (!defined($user)) {
	if ($isupdate) {
	    print STDERR "Could not locate $user_uuid for UpdateTicket\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No user found for UpdateTicket");
	}
	$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");
	}
    }
    return GetTicketAuxAux($slice, $user, $rspecstr,
			   $isupdate, $impotent, $v2, $level, $ticket);
}
sub GetTicketAuxAux($$$$$$$$)
{
    my ($slice, $user,
	$rspecstr, $isupdate, $impotent, $v2, $level, $ticket) = @_;
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state

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

    my $rspec =
	eval { XMLin($rspecstr, KeyAttr => [],
		     ForceArray => ["node", "link", "interface",
				    "interface_ref", "linkendpoints"]) };
    if ($@) {
	print STDERR "XMLin error: $@\n";
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "XML error in rspec");
    }

    #
    # 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");
	}
	
	#
	# Do we need a policy limit?
	#
	my $diff = $when - time();
	if ($diff < (60 * 5) || $diff > (3600 * 24 * 100)) {
	    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 ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
    
    #
    #
    # Lock the slice from further access.
    #
    if ($slice->Lock() != 0) {
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->BusyResponse("slice");
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	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 (!$isupdate) {
	if (defined($aggregate)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Already have an aggregate for slice");
	    goto bad;
	}
    }
    elsif ($v2 && $level && !defined($ticket) && !defined($aggregate)) {
	print STDERR "No aggregate for $slice in version two API\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }

    #
    # Firewall hack; just a flag in the rspec for now.
    #
    if (exists($rspec->{'needsfirewall'}) && $rspec->{'needsfirewall'}) {
	if ($slice->SetFirewallFlag($rspec->{'needsfirewall'}) != 0) {
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
    }

    #
    # We need this now so we can form a virtual topo.
    #
    my $slice_experiment = GeniExperiment($slice);
    if (!defined($slice_experiment)) {
	print STDERR "Could not create new Geni slice experiment!\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    my $pid = $slice_experiment->pid();
    my $eid = $slice_experiment->eid();

    #
    # Mark the experiment locally as coming from the cooked interface.
    # This changes what tmcd returns to the local nodes.
    #
    if (exists($rspec->{'generated_by'}) &&
	$rspec->{'generated_by'} eq "libvtop") {
	$slice_experiment->Update({"geniflags" =>
				       $Experiment::EXPT_GENIFLAGS_EXPT|
				       $Experiment::EXPT_GENIFLAGS_COOKED});
    }
    
    #
    # Create a virt topology object. We are going to load this up as we
    # process the rspec.
    #
    my $virtexperiment = VirtExperiment->CreateNew($slice_experiment);
    if (!defined($virtexperiment)) {
	print STDERR "Could not create VirtExperiment object!\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    # Turn off fixnode; we will control this on the commandline.
    $virtexperiment->allowfixnode(0);

    # This is where nodes are parked until a ticket is redeemed.
    # This experiment no longer has to exist.
    my $reserved_holding = Experiment->Lookup("GeniSlices", "reservations");

    #
    # An rspec is a structure that requests specific nodes. If those
    # nodes are available, then reserve it. Otherwise the ticket
    # cannot be granted.
    #
    my %namemap  = ();
    my %colomap  = ();
    my %ifacemap = ();
    my %nodemap  = ();
    my @nodeids  = ();
    my %lannodes = ();
    my @dealloc;

    #
    # If this is a ticket update, we want to seed the namemap with
    # existing nodes. This is cause the rspec might refer to wildcards
    # that were already bound in a previous call. We also want to know
    # what nodes are currently reserved in case we have to release some.
    #
    if ($isupdate) {
	$slice_experiment->ClearBackupState();
	if ($slice_experiment->BackupVirtualState()) {
	    print STDERR "Could not backup virtual state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	if ($slice_experiment->RemoveVirtualState()) {
	    print STDERR "Could not remove virtual state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	$restorevirt = 1;

	if ($slice_experiment->BackupPhysicalState()) {
	    print STDERR "Could not backup physical state!\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR);
	    goto bad;
	}
	my $oldrspec;
	if ($v2 && defined($aggregate)) {
	    $oldrspec = $aggregate->GetManifest(0);
	}
	else {
	    $oldrspec = $ticket->rspec();
	}
	
	foreach my $ref (@{$oldrspec->{'node'}}) {
	    my $resource_uuid = $ref->{'component_uuid'} || $ref->{'uuid'};
	    my $manager_uuid  = $ref->{'component_manager_uuid'};
	    my $node_nickname = $ref->{'virtual_id'} || $ref->{'nickname'};
	    my $colocate      = $ref->{'colocate'} || $ref->{'phys_nickname'};

	    # Let remote nodes pass through.
	    next
		if (defined($manager_uuid) &&
		    !GeniHRN::Equal( $manager_uuid, $ENV{'MYURN'} ) &&
		    $manager_uuid ne $ENV{'MYUUID'});

	    # Skip lan nodes; they are fake.
	    next
		if (exists($ref->{'node_type'}) &&
		    exists($ref->{'node_type'}->{'type_name'}) &&
		    $ref->{'node_type'}->{'type_name'} eq "lan");

	    my $node = LookupNode($resource_uuid);
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Bad resource $resource_uuid in ticket");
		goto bad;
	    }

	    #
	    # Grab the reservation. For backwards compatibility, we want
	    # to find nodes in the reservations holding area, and move them
	    # into the slice experiment. The holding area is no longer going
	    # to be used, at least not until we have a reservations system.
	    #
	    my $reservation = $node->Reservation();
	    if (defined($reservation) &&
		defined($reserved_holding) &&
		$reservation->SameExperiment($reserved_holding)) {
		if ($node->MoveReservation($slice_experiment)) {
		    print STDERR "Could not move $node to $slice_experiment\n";
		    goto bad;
		}
		$node->Refresh();
	    }
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }

    print STDERR Dumper($rspec);

    foreach my $ref (@{$rspec->{'node'}}) {
	my $resource_uuid = $ref->{'component_uuid'} || $ref->{'uuid'};
	my $manager_uuid  = $ref->{'component_manager_uuid'};
	my $node_nickname = $ref->{'virtual_id'} || $ref->{'nickname'};
	my $colocate      = $ref->{'colocate'} || $ref->{'phys_nickname'};
	my $subnode_of    = $ref->{'subnode_of'};
	my $virtualization_type    = $ref->{'virtualization_type'};
	my $virtualization_subtype = $ref->{'virtualization_subtype'};
	my $exclusive     = $ref->{'exclusive'};
	my $pctype;
	my $osname;
	my $node;

	# Let remote nodes pass through.
	next
	    if (defined($manager_uuid) &&
		!GeniHRN::Equal( $manager_uuid, $ENV{'MYURN'} ) &&
		$manager_uuid ne $ENV{'MYUUID'});

	#
	# Lan nodes are fake and do not go into the virt topo. Need
	# to remember them though, for when we do the links below.
	# They are still in the returned ticket though. 
	#
	if (exists($ref->{'node_type'}) &&
	    exists($ref->{'node_type'}->{'type_name'}) &&
	    $ref->{'node_type'}->{'type_name'} eq "lan") {
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
			$osname = "OPENVZ-STD";
		    }
		    $pctype = "pcvm";
		}
		else {
		    goto raw;
		}
	    }
	    else {
	      raw:
		# Lets force to exclusive real node.
		$ref->{'exclusive'} = $exclusive = 1;
		$ref->{'virtualization_type'} = "raw";
	    }
	}
	else {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtualization_type");
	    goto bad;

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

	#
	# Allow wildcarding.
	#
	if (!defined($resource_uuid) || $resource_uuid eq "*") {
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
	    }
	}
	else {
	    $node = LookupNode($resource_uuid);

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad resource $resource_uuid");
		goto bad;
	    }
	    $pctype = $node->type()
		if (!defined($pctype));
	}
	#
	# If no osname by this point, try for the default.
	#
	if (defined($node) && !defined($osname)) {
	    if (defined($node->default_osid())) {	    
		my $osinfo = OSinfo->Lookup($node->default_osid());
		$osname = $osinfo->osname()
		    if (defined($osinfo));
	    }
	}
	# The slot does not like to be NULL.
	$osname = ""
	    if (!defined($osname));
	
	# Need some kind of default.
	$pctype = "pc"
	    if (!defined($pctype));
	
	my $nodeblob = {"vname"   => $node_nickname,
			"type"    => $pctype,
			"osname"  => $osname,
			"ips"     => '', # deprecated
			"cmd_line"=> '', # bogus
			"fixed"   => (defined($subnode_of) ? $subnode_of :
				      defined($node) ? $node->node_id() : ""),
			};

	# Tarball and startup command.
	if (exists($ref->{'startup_command'})) {
	    my $startupcmd = $ref->{'startup_command'};
	    
	    if (! TBcheck_dbslot($startupcmd, "virt_nodes", "startupcmd",
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Invalid startup command");
		goto bad;
	    }
	    $nodeblob->{'startupcmd'} = $startupcmd;
	}
	if (exists($ref->{'tarfiles'})) {
	    my $tarfiles = $ref->{'tarfiles'};
	    
	    if (! TBcheck_dbslot($tarfiles, "virt_nodes", "tarfiles",
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Invalid tarfiles");
		goto bad;
	    }
	    $nodeblob->{'tarfiles'} = $tarfiles;
	}

	my $virtnode = $virtexperiment->NewTableRow("virt_nodes", $nodeblob);
	if (!defined($virtnode)) {
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					     "Error creating virtnode");
	    goto bad;
	}

	$virtexperiment->NewTableRow("virt_node_desires",
				     {"vname"    => $node_nickname,
				      "desire"   => "pcshared",
				      "weight"   => 0.95})
	    if (!defined($exclusive) || !$exclusive);

	# Store reference so we can munge it below. 
	$nodemap{$node_nickname} = {"rspec"    => $ref,
				    "virtnode" => $virtnode};
	
	#
	# Look for interface forward declarations that will be used later
	# in the link specifications. 
	#
	next
	    if (!exists($ref->{'interface'}));
	
	foreach my $linkref (@{$ref->{'interface'}}) {
	    my $component_id = $linkref->{"component_id"};
	    my $virtual_id   = $linkref->{"virtual_id"};

	    if (!defined($virtual_id)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			     "Must provide a virtual_id for interfaces");
		goto bad;
	    }
	    
	    $ifacemap{$node_nickname} = {}
	        if (!exists($ifacemap{$node_nickname}));

	    # port counter.
	    my $vport = scalar(keys(%{ $ifacemap{$node_nickname} }));

	    # Store reference so we can munge it below. 
	    $ifacemap{$node_nickname}->{$virtual_id} = {"rspec" => $linkref,
							"vport" => $vport};

	    # This is used after the mapper runs since it uses vname:vport.
	    $ifacemap{"$node_nickname:$vport"} = $linkref;
	}
    }

    goto skiplinks
	if (!exists($rspec->{'link'}));
    
    #
    # Now deal with links for wildcarded nodes. We need to fill in the
    # node_uuid.
    #
    my $linknum = 1;
    
    foreach my $linkref (@{$rspec->{'link'}}) {
	my $lanname    = $linkref->{"nickname"} || $linkref->{"virtual_id"};
	my $istunnel   = (exists($linkref->{'link_type'}) &&
			  $linkref->{'link_type'} eq "tunnel");
	my $interfaces = $linkref->{'linkendpoints'} ||
	    $linkref->{'interface_ref'};
	my $ifacenum   = 1;

	if (!defined($lanname)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Must provide a virtual_id for links");
	    goto bad;
	}

	#
	# Ick. Before we create the virt_lan_lans entry, we have to check
	# inside to see if one of the interfaces is connected to a lan
	# node. In this case, we want to reuse (if its been created) the
	# lan name, rather then a bunch of links with one interface, which
	# would result in a bogus topology. 
	#
	if (!$istunnel) {
	    foreach my $ref (@{ $interfaces }) {
		my $node_nickname = $ref->{'virtual_node_id'} ||
		    $ref->{'node_nickname'};

		if (exists($lannodes{$node_nickname})) {
		    $lanname = $node_nickname;
		}
	    }
	    if (!defined($virtexperiment->Find("virt_lan_lans", $lanname))) {
		$virtexperiment->NewTableRow("virt_lan_lans",
					     {"vname" => $lanname});
	    }
	}
	
	foreach my $ref (@{ $interfaces }) {
	    my $node_nickname = $ref->{'virtual_node_id'} ||
		$ref->{'node_nickname'};
	    my $iface_id     = $ref->{'virtual_interface_id'} ||
		$ref->{'iface_name'};

	    if (!defined($node_nickname)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$lanname: Need node id for links");
		goto bad;
	    }
	    if (!defined($iface_id)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$lanname: Need interface id for links");
		goto bad;
	    }

	    #
	    # Look for links that are really lans; one of the interfaces
	    # is on a fake lan node, which we caught above. Just skip it
	    # since in the virt topo, a lan is just a link with more then
	    # two nodes.
	    #
	    next
		if (exists($lannodes{$node_nickname}));

	    if ($istunnel) {
		# Might be the other side. Skip for now; might bite later.
		next
		    if (!exists($namemap{$node_nickname}));

		# Not doing anything else.
		next;
	    }
	    if (!exists($ifacemap{$node_nickname})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$lanname: No such virtual_node_id: ".
				 "$node_nickname");
		goto bad;
	    }
	    
	    #
	    # Sanity check the interface.
	    #
	    if (!exists($ifacemap{$node_nickname}->{$iface_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$lanname: No such interface on component: ".
				 "$node_nickname:$iface_id");
		goto bad;
	    }
	    my $iface_ref   = $ifacemap{$node_nickname}->{$iface_id}->{"rspec"};
	    my $iface_name  = $iface_ref->{"component_id"} || "";
	    if( GeniHRN::IsValid( $iface_name ) ) {
		my ($urn_authority,$urn_node,$urn_iface) =
		    GeniHRN::ParseInterface( $iface_name );
		$iface_name = $urn_iface;
	    }
	    my $iface_vport = $ifacemap{$node_nickname}->{$iface_id}->{"vport"};

	    # XXX
	    my $ip     = "10.10.${linknum}.${ifacenum}";
	    my $mask   = "255.255.255.0";
	    my $member = "$node_nickname:$iface_vport";
	    my $bandwidth = 100000;

	    # Let user override.
	    $bandwidth = $linkref->{'bandwidth'}
	        if (exists($linkref->{'bandwidth'}));
	    
	    $virtexperiment->NewTableRow("virt_lans",
					 {"vname"       => $lanname,
					  "vnode"       => $node_nickname,
					  "vport"       => $iface_vport,
					  "trivial_ok"  => 1,
					  "ip"          => $ip,
					  "delay"       => 0.0,
					  "bandwidth"   => $bandwidth, # kbps
					  "lossrate"    => 0.0,
					  "member"      => $member,
					  "mask"        => $mask,
					  "rdelay"      => 0.0,
					  "rbandwidth"  => $bandwidth, # kbps
					  "rlossrate"   => 0.0,
					  "fixed_iface" => $iface_name});
	    $ifacenum++;
	}
	$linknum++;
    }
  skiplinks:
    $virtexperiment->Dump();
    if ($virtexperiment->Store()) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	goto bad;
    }

    # Must chdir to the work directory for the mapper.
    if (! chdir($slice_experiment->WorkDir())) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	goto bad;
    }

    # Do a render cause its nice to have on the show experiment page.
    system("$PRERENDER -r $pid $eid");
    system("$PRERENDER -t $pid $eid");

    #
    # Now run the mapper in impotent mode. The idea is get a solution
    # without allocating any nodes. If we get a solution, and we can
    # allocate the nodes, we update the rspec with the physical info.
    #
    my $tmpfile = POSIX::tmpnam();

    # First a prerun to get the node counts and verify topo.
    system("$VTOPGEN -p $pid $eid");
    if ($?) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not verify topo");
	goto bad;
    }
    system("$MAPPER -n -d -v -m 3 -u -o $tmpfile $pid $eid");
    if ($?) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not map to resources");
	unlink($tmpfile);
	if ($isupdate) {
	    $slice_experiment->RemovePhysicalState();
	    $slice_experiment->RestorePhysicalState();
	}
	# Dump the vtop.
	if (-e "$pid-$eid.vtop") {
	    print STDERR "----------------------------------------------\n";
	    print STDERR "------------------ Vtop File -----------------\n";
	    my $log = `cat $pid-$eid.vtop`;
	    print STDERR $log . "\n";
	    print STDERR "----------------------------------------------\n";
	}	    
	#
	# Lets dump the error log too, so it ends up in the email.
	# Have to figure out a better approach for this.
	#
	if (-e "assign.log") {
	    print STDERR "----------------------------------------------\n";
	    print STDERR "------------- Assign Error Log ---------------\n";
	    my $log = `cat assign.log`;
	    print STDERR $log . "\n";
	    print STDERR "----------------------------------------------\n";
	}	    
	goto bad;
    }
    my $solution =
	eval { XMLin($tmpfile, KeyAttr => [],
		     ForceArray => ["node", "link", "interface",
				    "interface_ref", "linkendpoints"]) };
    if ($@) {
	print STDERR "XMLin error: $@\n";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "XML error in solution");
	goto bad;
    }

    unlink($tmpfile);
    print Dumper($solution);

    foreach my $ref (@{$solution->{'node'}}) {
	my $virtual_id     = $ref->{"virtual_id"};
	my $component_uuid = $ref->{"component_uuid"};
	if (!exists($nodemap{$virtual_id})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Mapper inserted nodes you did not want");
	    goto bad;
	}
	my $rspec          = $nodemap{$virtual_id}->{'rspec'};
	my $virtnode       = $nodemap{$virtual_id}->{'virtnode'};
	my $node           = LookupNode($component_uuid);
	my $colocate       = $rspec->{'colocate'} ||
	    $rspec->{'phys_nickname'};
	my $exclusive      = $rspec->{'exclusive'};
	my $subnode_of     = $rspec->{'subnode_of'};
	$exclusive = 0
	    if (!defined($exclusive));
	
	$rspec->{'component_urn'} = GeniHRN::Generate( $OURDOMAIN, "node",
						       $node->node_id() );
	$rspec->{'component_uuid'} = $component_uuid;
	$rspec->{'component_manager_urn'} = $ENV{'MYURN'};
	$rspec->{'component_manager_uuid'} = $ENV{'MYUUID'};

	# Also update the virtexperiment table row.
	# Do not update subnodes; they are fixed to the parent,
	# while the parent is fixed to an actual node.
	if (!defined($subnode_of)) {
	    $virtnode->fixed($node->node_id());
	}

	#
	# Shared and virt nodes do not need to be allocated.
	#
	# XXX This is going to cause breakage since the reservations
	# are not recorded anyplace until the ticket is redeemed.
	#
	if (! ($node->sharing_mode() || $node->isplabphysnode() ||
	       ($node->isremotenode() && !$exclusive))) {
	    # Need to allocate this node unless already mapped.
	    push(@nodeids, $node->node_id())
		if (!exists($namemap{$virtual_id}));
	}
	$namemap{$virtual_id} = $node;
	$colomap{$colocate} = $node
	    if (defined($colocate));
    }
    foreach my $ref (@{$solution->{'link'}}) {
	my $nickname          = $ref->{"virtual_id"};
	my $interfaces        = $ref->{'interface_ref'};

	foreach my $iface_ref (@{ $interfaces }) {
	    my $virtual_node_id   = $iface_ref->{"virtual_node_id"};
	    my $virtual_port_id   = $iface_ref->{"virtual_port_id"};
	    my $component_id      = $iface_ref->{"component_id"};
	    my $linkref     = $ifacemap{"$virtual_node_id:$virtual_port_id"};

	    $component_id = "lo0"
		if (!defined($component_id));
	
	    $linkref->{'component_id'} = $component_id;
	}
    }
    # Store the virt topo again since we changed it above.
    $virtexperiment->Dump();
    if ($virtexperiment->Store()) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef);
	goto bad;
    }

    print Dumper($rspec);

    # 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 some nodes");
	    goto bad;
	}
	# In case the code below fails, before ticket is created.
	@dealloc = @nodeids;
    }

    #
    # For the version 2 minimal API, just return the annotated rspec.
    #
    if ($v2 && $level == 0) {
	# Bad, should leave it locked, but Redeem below would fail, and
	# this whole arrangement is temporary, so lets not worry about it.
	$slice->UnLock();
	return $rspec;
    }
    
    #
    # Create a new ticket.
    #
    my $newticket = GeniTicket->Create($authority, $user, $rspec);
    if (!defined($newticket)) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not create GeniTicket object");
	goto bad;
    }
    $newticket->SetSlice($slice->uuid());
    
    if ($newticket->Sign()) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Could not sign Ticket");
	goto bad;
    }
    if (!$impotent && $newticket->Store()) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Internal error storing Ticket");
	goto bad;
    }

    if ($isupdate && defined($ticket)) {
	#
	# Delete (not release) the old ticket. 
	#
	$ticket->Delete(TICKET_RELEASED)
	    if ($ticket->stored());
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $newticket->asString());
  bad:
    system("$PRERENDER -r $pid $eid")
	if (defined($slice_experiment));
    #
    # Have to be careful in a ticket update, to not release nodes that
    # might be referenced in the old ticket. 
    #
    if ($isupdate) {
	if (defined($newticket)) {
	    # Delete, not Release (which frees nodes).
	    $newticket->Delete(TICKET_PURGED);
	}
	if (@dealloc) {
	    system("export NORELOAD=1; ".
		   "$NFREE -x -q GeniSlices $eid @dealloc");
	}
	if (defined($slice_experiment) && $restorevirt) {
	    $slice_experiment->RemoveVirtualState();
	    $slice_experiment->RestoreVirtualState();
	}
    }
    else {
	# Release will free the nodes.
	if (defined($newticket)) {
	    $newticket->Release(TICKET_PURGED);
	}
	elsif (@dealloc) {
	    system("export NORELOAD=1; ".
		   "$NFREE -x -q GeniSlices $eid @dealloc");
	}
	#
	# Lets leave the experiment lying around; it will get cleaned
	# up when the slice is expired. But need to kill off the virtual
	# topo we might have added to it. 
	#
	$slice_experiment->RemoveVirtualState()
	    if (defined($slice_experiment));
    }
    if ($v2 && $level == 0) {
	CleanupDeadSlice($slice, 1)
	    if (defined($slice));
	return $response;
    }
    $slice->UnLock()
	if (defined($slice));
    $ticket->UnLock()
	if (defined($ticket) && $ticket->stored());
    return $response;
}

#
# Redeem a ticket
#
sub RedeemTicket($)
{
    my ($argref) = @_;

    return SliverWork($argref, 0);
}

#
# Update a sliver
#
sub UpdateSliver($)
{
    my ($argref) = @_;

    return SliverWork($argref, 1);
}

#
# Utility function for above routines.
#
sub SliverWork($$)
{
    my ($argref, $isupdate) = @_;
    my $credstr    = $argref->{'credential'};
    my $ticketstr  = $argref->{'ticket'};
    my $impotent   = $argref->{'impotent'};
    my $keys       = $argref->{'keys'};

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

    if (! (defined($credstr) && defined($ticketstr))) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($credstr);
    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!");
    }

    my $ticket = GeniTicket->CreateFromSignedTicket($ticketstr);
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }
    # Only unredeemed tickets are stored in the DB.
    if (!$ticket->stored()) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This ticket was already redeemed!");
    }
    # Make sure the ticket was issued to the caller.
    if ($ticket->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your ticket!");
    }
    # Make sure the ticket target is this Manager
    if ($ticket->target_uuid() ne $ENV{'MYUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "This ticket is for another authority!");
    }
    return SliverWorkAux($credential, $ticket,
			 $keys, $isupdate, $impotent, 0, 0);
}

sub SliverWorkAux($$$$$$$)
{
    my ($credential, $object, $keys, $isupdate, $impotent, $v2, $level) = @_;
    my $didfwsetup  = 0;
    my $restorephys = 0;	# Flag to restore physical state
    my $ticket;
    my $rspec;

    # V2 API support.
    if ($v2 && $level == 0) {
	$rspec = $object;
    }
    else {
	$ticket = $object;
	$rspec = $ticket->rspec();
    }

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "instantiate" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    my $owner_uuid = $credential->owner_uuid();
    my $owner_cert = $credential->owner_cert();
    my $message    = "Error creating sliver/aggregate";

    #
    # For now, there can be only a single toplevel aggregate per slice.
    #
    my $aggregate;
    my $slice;
    my $slice_uuid;
    
    if ($isupdate) {
	$aggregate = GeniAggregate->Lookup($credential->target_uuid());

	if (!defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Sliver cannot be found");
	}
	$slice_uuid = $aggregate->slice_uuid();
	$slice = GeniSlice->Lookup($slice_uuid);
	if (!defined($slice)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice record for $slice_uuid");
	}
    }
    else {
	$slice_uuid = $credential->target_uuid();
	$slice = GeniSlice->Lookup($slice_uuid);
	if (!defined($slice)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice record for $slice_uuid");
	}
	$aggregate  = GeniAggregate->SliceAggregate($slice);

	if (defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Already have an aggregate for slice");
	}
    }
    $ticket->SetSlice($slice_uuid)
	if (defined($ticket));
    
    if ($slice->Lock() != 0) {
	$ticket->UnLock()
	    if (defined($ticket));
	return GeniResponse->BusyResponse("slice");
    }

    # Do not redeem an expired ticket.
    if (defined($ticket) && $ticket->Expired()) {
	$slice->UnLock();
	$ticket->UnLock();
	return GeniResponse->Create(GENIRESPONSE_EXPIRED, undef,
				    "Ticket has expired");
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket));
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "Slice has been shutdown");
    }

    #
    # Create the user.
    #
    my $owner = GeniUser->Lookup($owner_uuid);
    if (!defined($owner)) {
	$owner = CreateUserFromCertificate($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)) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket));
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local experiment for slice");
    }
    my $pid = $experiment->pid();
    my $eid = $experiment->eid();

    #
    # Figure out what nodes to allocate or free. 
    #
    my %physnodes= ();
    my %nodemap  = ();
    my %linkmap  = ();
    my %newnodes = ();
    my %lannodes = ();
    my %colomap  = ();
    my @allocated= ();
    my @freenodes= ();
    my @freelinks= ();
    my $needplabslice = 0;

    print Dumper($rspec);

    #
    # Find current slivers and save.
    #
    if (defined($aggregate)) {
	my @slivers;
	if ($aggregate->SliverList(\@slivers) != 0) {
	    $message = "Could not get sliverlist for $aggregate";
	    goto bad;
	}
	foreach my $s (@slivers) {
	    if (ref($s) eq "GeniSliver::Node") {
		$nodemap{$s->nickname()} = $s;
	    }
	    elsif (ref($s) eq "GeniAggregate::Link" ||
		   ref($s) eq "GeniAggregate::Tunnel") {
		# XXX See the constructor in GeniAggregate.
		my ($linkname) = ($s->hrn() =~ /\.([-\w]*)$/);
		$linkmap{$linkname} = $s;
	    }
	    else {
		$message = "Only nodes or links allowed";
		goto bad;
	    }
	}
    }

    #
    # 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:.\/]+/)) {
	    $message = "Illegal valid_until in rspec";
	    goto bad;
	}
	# Convert to a localtime.
	my $when = timegm(strptime($expires));
	if (!defined($when)) {
	    $message = "Could not parse valid_until";
	    goto bad;
					
	}
	#
	# Do we need a policy limit?
	#
	my $diff = $when - time();
	if ($diff < (60 * 5) || $diff > (3600 * 24 * 100)) {
	    $message = "valid_until out of range";
	    goto bad;
	}
	if ($slice->SetExpiration($when) != 0) {
	    $message = "Could not set expiration time";
	    goto bad;
	}
    }

    # Nodes are in this holding experiment.
    # This experiment no longer has to exist!
    my $reserved_holding = Experiment->Lookup("GeniSlices", "reservations");

    #
    # Make sure all nodes requested are allocated. 
    #
    foreach my $ref (@{$rspec->{'node'}}) {
	my $resource_uuid = $ref->{'component_urn'} ||
	    $ref->{'component_uuid'} || $ref->{'uuid'};
	my $node_nickname = $ref->{'virtual_id'} || $ref->{'nickname'};
	my $manager_uuid  = $ref->{'component_manager_urn'} ||
	    $ref->{'component_manager_uuid'};
	
	# Let remote nodes pass through.
	next
	    if (defined($manager_uuid) &&
		!GeniHRN::Equal( $manager_uuid, $ENV{'MYURN'} ) &&
		$manager_uuid ne $ENV{'MYUUID'});

	#
	# Lan nodes are fake and do not go into the virt topo. Need
	# to remember them though, for when we do the links below.
	# They are still in the ticket though. 
	#
	if (exists($ref->{'node_type'}) &&
	    exists($ref->{'node_type'}->{'type_name'}) &&
	    $ref->{'node_type'}->{'type_name'} eq "lan") {
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

	my $node = LookupNode($resource_uuid);
	if (!defined($node)) {
	    $message = "Bad resource_uuid $resource_uuid";
	    goto bad;
	}

	#
	# Plab nodes do not need to be allocated.
	#
	if ($node->isplabphysnode()) {
	    $needplabslice = 1;
	    next;
	}
	# These are not allocated either.
	if ($node->sharing_mode()) {
	    next;
	}

	#
	# See if the node is properly reserved. 
	#
	my $reservation = $node->Reservation();
	if (defined($reservation)) {
	    if (defined($reserved_holding) &&
		$reservation->SameExperiment($reserved_holding)) {
		# This is for backwards compatibility.
		if ($node->MoveReservation($experiment)) {
		    print STDERR "Could not move $node to $experiment\n";
		    goto bad;
		}
		$node->Refresh();
	    }
	    elsif (!$reservation->SameExperiment($experiment)) {
		$message = "$resource_uuid ($node) is not available";
		goto bad;
	    }
	}
	else {
	    $message = "$resource_uuid ($node) is not available";
	    goto bad;
	}
    
	# Unincorporated nodes have no genisliver_idx.
	my $restable = $node->ReservedTableEntry();
	if (defined($restable) &&
	    !defined($restable->{'genisliver_idx'})) {
	    $newnodes{$node->node_id()} = $node;
	    next;
	}
    }

    #
    # What *slivers* need to be released? This may result in physical
    # nodes being released later.
    #
    foreach my $nickname (keys(%nodemap)) {
	my $sliver   = $nodemap{$nickname};
	my $needfree = 1;
	
	foreach my $ref (@{$rspec->{'node'}}) {
	    my $virtual_id = $ref->{'virtual_id'} || $ref->{'nickname'};
	    if ($nickname eq $virtual_id) {
		$needfree = 0;
		last;
	    }
	}
	if ($needfree) {
	    #
	    # Not yet.
	    #
	    my @dlist;
	    if ($sliver->DependentSlivers(\@dlist) != 0) {
		print STDERR "Could not get DependentSlivers for $sliver\n";
		goto bad;
	    }
	    if (@dlist) {
		$message = "Must tear down dependent slivers first";
		goto bad;
	    }
	    push(@freenodes, $sliver);
	}
    }

    #
    # Create an emulab nonlocal user for tmcd.
    #
    if ($owner->BindToSlice($slice)) {
	$message = "Error binding user to slice";
	print STDERR "$message\n";
	goto bad;
    }
			

    # 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($aggregate)) {
	#
	# Form the hrn from the slicename.
	#
	my $hrn = "${OURDOMAIN}." . $slice->slicename();
	
	$aggregate = GeniAggregate->Create($slice, $owner, "Aggregate",
					   $hrn, $slice->hrn());
	if (!defined($aggregate)) {
	    $message = "Could not create GeniAggregate object";
	    print STDERR "$message\n";
	    goto bad;
	}
    }

    #
    # We need to tear down links that are no longer in the rspec or
    # have changed.
    #
    foreach my $linkname (keys(%linkmap)) {
	my $needfree = 1;
	
	foreach my $linkref (@{$rspec->{'link'}}) {
	    my $nickname = $linkref->{"nickname"} || $linkref->{"virtual_id"};

	    if ($linkname eq $nickname) {
		$needfree = 0;
		last;
	    }
	}
	if ($needfree) {
	    my $s = $linkmap{$linkname};
	    push(@freelinks, $s);
	    delete($linkmap{$linkname});
	}
    }

    if ($isupdate) {
	#
	# Backup physical state in case of failure.
	#
	if ($experiment->ClearBackupState() ||
	    $experiment->BackupPhysicalState()) {
	    print STDERR "Could not backup physical state!\n";
	    goto bad;
	}
	$restorephys = 1;

	if (!$v2) {
	    system("$SNMPIT -r $pid $eid");
	    if ($?) {
		print STDERR "Could not tear down vlans\n";
		goto bad;
	    }
	}
    }
    else {
	#
	# Remove physical state.
	#
	if ($experiment->RemovePhysicalState()) {
	    print STDERR "Could not remove physical state!\n";
	    goto bad;
	}
    }

    #
    # Now run the mapper again. All the resources are fixed, and it should
    # just run like it did the first time. The difference is that it will
    # fill out the physical tables this time.
    #
    # Must chdir to the work directory for the mapper.
    if (! chdir($experiment->WorkDir())) {
	print STDERR "Could not chdir to workdir\n";
	goto bad;
    }
    # Add -u for update mode, but not -f (fixnode). 
    system("$MAPPER -d -v -u -m 3 $pid $eid");
    if ($?) {
	print STDERR "Mapper failed!\n";
	# Dump the vtop.
	if (-e "$pid-$eid.vtop") {
	    print STDERR "----------------------------------------------\n";
	    print STDERR "------------------ Vtop File -----------------\n";
	    my $log = `cat $pid-$eid.vtop`;
	    print STDERR $log . "\n";
	    print STDERR "----------------------------------------------\n";
	}	    
	#
	# Lets dump the error log too, so it ends up in the email.
	# Have to figure out a better approach for this.
	#
	if (-e "assign.log") {
	    print STDERR "----------------------------------------------\n";
	    print STDERR "------------- Assign Error Log ---------------\n";
	    my $log = `cat assign.log`;
	    print STDERR $log . "\n";
	    print STDERR "----------------------------------------------\n";
	}	    
	goto bad;
    }

    #
    # Must do this after the mapper runs.
    #
    if (system("$TARFILES_SETUP $pid $eid")) {
	print STDERR "Could not setup tarfiles\n";
	goto bad;
    }

    #
    # Now for each resource (okay, node) in the ticket create a sliver and
    # add it to the aggregate.
    #
    my %slivers   = ();
    my @plabnodes = ();
    my %ifacemap  = ();
    my %rspecmap  = ();
    foreach my $ref (@{$rspec->{'node'}}) {
	my $resource_uuid = $ref->{'component_uuid'} || $ref->{'uuid'};
	my $virtual_id    = $ref->{'virtual_id'} || $ref->{'nickname'};
	my $manager_uuid  = $ref->{'component_manager_uuid'};

	$rspecmap{$virtual_id} = $ref;

	# Let remote nodes pass through.
	next
	    if (defined($manager_uuid) &&
		!GeniHRN::Equal( $manager_uuid, $ENV{'MYURN'} ) &&
		$manager_uuid ne $ENV{'MYUUID'});

	# Skip lan nodes; they are fake.
	next
	    if (exists($lannodes{$virtual_id}));

	#
	# For a map of the interfaces.
	#
	foreach my $linkref (@{$ref->{'interface'}}) {
	    my $component_id     = $linkref->{"component_id"};
	    my $virtual_iface_id = $linkref->{"virtual_id"};

	    $ifacemap{$virtual_id} = {}
	        if (!exists($ifacemap{$virtual_id}));

	    # Store reference so we can munge it below. 
	    $ifacemap{$virtual_id}->{$virtual_iface_id} = $component_id;
	}

	# Already in the aggregate?
	next
	    if (grep {$_ eq $virtual_id} keys(%nodemap));
	
	my $node = LookupNode($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 $virtual_id";
	    goto bad;
	}
	$slivers{$sliver->uuid()} = $sliver;
	$nodemap{$virtual_id} = $sliver;

	# For the manifest.
	$ref->{'sliver_urn'} = $sliver->sliver_urn();

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

	# See below; setup all plab nodes at once.
	if ($node->isplabphysnode()) {
	    my $vnode = LookupNode($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 $linkref (@{$rspec->{'link'}}) {
	my @linkslivers  = ();
	my $linkname     = $linkref->{"nickname"} || $linkref->{"virtual_id"};
	my $interfaces   = $linkref->{'linkendpoints'} ||
	    $linkref->{'interface_ref'};

	if (! ($linkname =~ /^[-\w]*$/)) {
	    $message = "Bad name for link: $linkname";
	    goto bad;
	}

	# Do not worry about modifying a link that is setup. Later.
	next
	    if (grep {$_ eq $linkname} keys(%linkmap));

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

	    my $iface1ref   = (@{$interfaces})[0];
	    my $iface2ref   = (@{$interfaces})[1];
	    my $node1_id    = $iface1ref->{'virtual_node_id'};
	    my $node2_id    = $iface2ref->{'virtual_node_id'};
	    my $node1sliver = $nodemap{$node1_id};
	    my $node2sliver = $nodemap{$node2_id};
	    my $node1rspec  = $rspecmap{$node1_id};
	    my $node2rspec  = $rspecmap{$node2_id};

	    if (! (defined($node1sliver) || (defined($node2sliver)))) {
		$message = "$linkname: No local nodes for tunnel";
		goto bad;
	    }
	    if (! (defined($node1rspec) && (defined($node2rspec)))) {
		$message = "$linkname: Missing nodes for tunnels";
		goto bad;
	    }
	    my $tunnel = GeniAggregate::Tunnel->Create($slice,
						       $owner,
						       $node1sliver,
						       $node2sliver,
						       $linkref,
						       $node1rspec,
						       $node2rspec);

	    if (!defined($tunnel)) {
		$message = "Could not create tunnel aggregate for $linkname";
		goto bad;
	    }
	    $slivers{$tunnel->uuid()} = $tunnel;
	    $linkmap{$linkname} = $tunnel;
	    
	    # Manifest goes back to the user.
	    $linkref->{'sliver_uuid'} = $tunnel->uuid();
	    $linkref->{'sliver_urn'}  = $tunnel->urn();

	    # Add to the aggregate.
	    if ($tunnel->SetAggregate($aggregate) != 0) {
		$message = "Could not set aggregate for $tunnel to $aggregate";
		goto bad;
	    }
	    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;
	$linkmap{$linkname} = $linkaggregate;

	# Manifest goes back to the user.
	$linkref->{'sliver_uuid'} = $linkaggregate->uuid();
	$linkref->{'sliver_urn'}  = $linkaggregate->urn();

	# Add to the aggregate.
	if ($linkaggregate->SetAggregate($aggregate) != 0) {
	    $message = "Could not set aggregate for $linkaggregate ".
		"to $aggregate";
	    goto bad;
	}

	foreach my $ifaceref (@{ $interfaces }) {
	    my $iface_id   = $ifaceref->{'virtual_interface_id'};
	    my $node_id    = $ifaceref->{'virtual_node_id'};

	    #
	    # Look for links that are really lans; one of the interfaces
	    # is on a fake lan node, which we caught above. Just skip it
	    # since in the virt topo, a lan is just a link with more then
	    # two nodes.
	    #
	    next
		if (exists($lannodes{$node_id}));

	    my $nodesliver = $nodemap{$node_id};
	    
	    if (!defined($nodesliver)) {
		$message = "Link $linkname specifies a non-existent node";
		goto bad;
	    }
	    my $nodeobject= LookupNode($nodesliver->resource_uuid());
	    if (!defined($nodeobject)) {
		$message = "Could not find node object for $nodesliver";
		goto bad;
	    }

	    #
	    # The interface was set above.
	    #
	    my $iface_name = $ifacemap{$node_id}->{$iface_id};
	    if (!defined($iface_name)) {
		$message = "Inconsistent ifacemap; $node_id,$iface_id";
		goto bad;
	    }
	    my $interface;

	    if ($iface_name ne "lo0") {
		$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,
						       $nodeobject->node_id(),
						       $iface_name,
						       $linkname,
						       $ifaceref);
	    if (!defined($sliver)) {
		$message = "Could not create GeniSliver for ".
		    "$iface_name in $linkname";
		goto bad;
	    }
	    # Manifest goes back to the user.
	    $ifaceref->{'sliver_urn'}  = $sliver->sliver_urn();
	    $ifaceref->{'MAC'} = $interface->mac()
		if (defined($interface));
	    
	    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;
	}
    }

    # Do firewall stuff.
    if ($slice->needsfirewall()) {
	my @nodeids = map { $_->node_id() } values(%newnodes);

	if (@nodeids && doFWlans($experiment, FWADDNODES, \@nodeids) != 0) {
	    print STDERR "FireWall setup failed\n";
	    goto bad;
	}
	$didfwsetup = 1;
    }

    #
    # Now do the provisioning. The entire aggregate is provisioned, which
    # is extra work, but needed since running the mapper above might have
    # changed some important state.
    #
    if (!$impotent && $aggregate->Provision() != 0) {
	$message = "Could not provision $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 (!$v2) {
	if (system("$GENTOPOFILE $pid $eid")) {
	    print STDERR "$GENTOPOFILE failed\n";
	    goto bad;
	}
	if (system("$EXPORTS_SETUP")) {
	    print STDERR "$EXPORTS_SETUP 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;
	}
	system("$SNMPIT -t $pid $eid");
	if ($?) {
	    $message = "Could not set up vlans";
	    goto bad;
	}
    }
	
    # 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 Manifest.
    my $manifest =
	eval { XMLout($rspec, "NoAttr" => 1, RootName => "manifest") };
    if ($@) {
	print STDERR "Manifest: XMLout error: $@\n";
	print STDERR Dumper($rspec);
    }

    #
    # Move this elsewhere.
    #
    DBQueryWarn("replace into geni_manifests set ".
		"  manifest=". DBQuoteSpecial($manifest) . ", " .
		"  idx=NULL, slice_uuid='$slice_uuid', created=now()");

    #
    # The API states we return a credential to control the aggregate.
    #
    if (!$isupdate) {
	$experiment->SetState(EXPTSTATE_ACTIVE());
	
	my $sliver_credential = $aggregate->NewCredential($owner);
	if (!defined($sliver_credential)) {
	    $message = "Could not create credential";
	    goto bad;
	}
	$ticket->Redeem()
	    if (defined($ticket));
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				    [$sliver_credential->asString(),
				     $manifest]);
    }
    #
    # Free any slivers that were no longer wanted.
    #
    foreach my $s (@freelinks) {
	$s->UnProvision();
	$s->Delete(0);
    }
    foreach my $s (@freenodes) {
	$s->UnProvision();
	$s->Delete(0);
    }
    $ticket->Redeem()
	if (defined($ticket));
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $manifest);

  bad:
    foreach my $sliver (values(%slivers)) {
	$sliver->UnProvision(1)
	    if (! $impotent);
	$sliver->Delete(GENI_PURGEFLAG);
    }
    # Mark the nodes as no longer being incorporated. 
    if (keys(%newnodes)) {
	my @nodeids = map { $_->node_id() } values(%newnodes);
	
	if ($slice->needsfirewall() && $didfwsetup) {
	    if (@nodeids && doFWlans($experiment, FWDELNODES, \@nodeids)) {
		print STDERR "FireWall cleanup failed\n";
	    }
	}
	foreach my $node (values(%newnodes)) {
	    if ($node->ModifyReservation({"genisliver_idx" => 0})) {
		print STDERR "Could not clear genisliver_idx from $node\n";
	    }
	}
    }
    if ($isupdate) {
	#
	# Restore old physical state. 
	#
	if ($restorephys) {
	    if ($experiment->ReserveSharedBandwidth(1, 1) ||
		$experiment->RemovePhysicalState() ||
		$experiment->RestorePhysicalState()) {
		print STDERR "Could not restore backup state for $pid,$eid\n";
	    }
	}
	if (!$v2) {
	    system("$SNMPIT -t $pid $eid");
	    if ($?) {
		print STDERR "Could not restore vlans\n";
	    }
	}
    }
    elsif (!$v2) {
	system("$SNMPIT -r $pid $eid");
	if ($?) {
	    print STDERR "Could not tear down vlans\n";
	}
    }
    
    $aggregate->Delete(GENI_PURGEFLAG)
	if (defined($aggregate) && !$isupdate);
    
    $slice->UnLock();
    $ticket->UnLock()
	if (defined($ticket));
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef, $message);
}

#
# Renew a sliver
#
sub RenewSliver($)
{
    my ($argref) = @_;
    my $credstr  = $argref->{'credential'};
    my $expires  = $argref->{'valid_until'};

    if (! (defined($credstr) && defined($expires))) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential->CreateFromSigned($credstr);
    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!");
    }
    return RenewSliverAux($credential, $expires);
}

sub RenewSliverAux($$)
{
    my ($credential, $expires) = @_;
    my $target_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid(); 
    my $message     = "Error renewing aggregate";
    my $slice_uuid;
   
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    my $aggregate = GeniAggregate->Lookup($target_uuid);
    if (defined($aggregate)) {
	$slice_uuid = $aggregate->slice_uuid();
    }
    else {
	$slice_uuid = $target_uuid;
    }
    my $slice = GeniSlice->Lookup($slice_uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for $slice_uuid");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse("slice");
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$message = "Slice has been shutdown";
	goto bad;
    }
    my $experiment = GeniExperiment($slice);
    if (!defined($experiment)) {
	$message = "No local experiment for slice";
	goto bad;
    }

    #
    # Figure out new expiration time; this is the time at which we can
    # idleswap the slice out. 
    #
    if (! ($expires =~ /^[-\w:.\/]+/)) {
	$message = "Illegal valid_until in rspec";
	goto bad;
    }
    # Convert to a localtime.
    my $when = timegm(strptime($expires));
    if (!defined($when)) {
	$message = "Could not parse valid_until";
	goto bad;
    }
    #
    # Do we need a policy limit?
    #
    my $diff = $when - time();

    print STDERR "RenewSliver: $expires, $when, $diff\n";
    
    if ($diff < (60 * 5) || $diff > (3600 * 24 * 100)) {
	$message = "valid_until out of range";
	goto bad;
    }
    if ($slice->SetExpiration($when) != 0) {
	$message = "Could not set expiration time";
	goto bad;
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);

  bad:
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef, $message);
}

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

    if (! (defined($tickstr) && defined($credstr))) {
	return GeniResponse->MalformedArgsResponse();
    }
    my $ticket = GeniTicket->CreateFromSignedTicket($tickstr);
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }
    my $credential = GeniCredential->CreateFromSigned($credstr);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniCredential object");
    }
    $ticket->SetSlice($credential->target_uuid());
    
    #
    # Make sure the ticket was issued to the caller.
    #
    if ($ticket->owner_uuid() ne $ENV{'GENIUUID'}) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This is not your ticket!");
    }
    #
    # If the ticket is not stored, it is not a ticket that needs
    # to be released. It is a copy or a reissue. Needs more thought.
    #
    if (! $ticket->stored()) {
	return GeniResponse->Create(GENIRESPONSE_SUCCESS);
    }
    if ($ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
    if ($ticket->Release(TICKET_RELEASED) != 0) {
	print STDERR "Error releasing $ticket\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    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 $manifest    = $argref->{'manifest'};
    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!");
    }
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

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

    if (defined($manifest)) {
	$manifest =
	    eval { XMLin($manifest, KeyAttr => [],
			 ForceArray => ["node", "link", "interface",
					"interface_ref", "linkendpoints"]) };
	if ($@) {
	    print STDERR "XMLin error reading manifest: $@\n";
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Bad manifest");
	}
    }
    
    #
    # 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 (defined($manifest)) {
	print Dumper($manifest);
	
	#
	# This is not signed, so have to be very careful about using
	# anything inside it.
	#
	if ($sliver->ProcessManifest($manifest) != 0) {
	    $slice->UnLock();
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not process manifest");
	}
    }
    
    if (!$impotent && $sliver->Start($API_VERSION, 0) != 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'};

    $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");
    }
    #
    # 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!");
    }
    return DeleteSliverAux($credential, $impotent, 0);
}

sub DeleteSliverAux($$$)
{
    my ($credential, $impotent, $v2) = @_;
    my $response;

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "instantiate" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    my $sliver_uuid = $credential->target_uuid();
    my $user_uuid   = $credential->owner_uuid();
    
    #
    # 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_SEARCHFAILED, 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();
    }

    my $experiment = $slice->GetExperiment();
    my $pid = $experiment->pid();
    my $eid = $experiment->eid();

    if (!$impotent) {
	system("$SNMPIT -r $pid $eid");
	if ($?) {
	    print STDERR "Could not tear down vlans\n";
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					     "Could not tear down vlans");
	    goto bad;
	}
	
	#
	# A firewalled slice gets special treatment.
	#
	if ($slice->needsfirewall()) {
	    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($v2) != 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;
	}
	$experiment->RemovePhysicalState();
	$experiment->SetState(EXPTSTATE_SWAPPED());

	if (system("$EXPORTS_SETUP")) {
	    print STDERR "$EXPORTS_SETUP failed\n";
	}
	if (system("$NAMEDSETUP")) {
	    print STDERR "$NAMEDSETUP failed\n";
	}

	#
	# In the v2 API, caller returns a new ticket for the resources
	# (which were not released). 
	#
	if ($v2) {
	    # Slice still locked.
	    return 0;
	}
	$experiment->RemoveVirtualState();
	DBQueryWarn("delete from geni_manifests ".
		    "where slice_uuid='$slice_uuid'");
    }
    $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!");
    }

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "instantiate" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    #
    # 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!");
    }
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "instantiate" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    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");
    }
    #
    # 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!");
    }
    return GetSliverAux($credential);
}

sub GetSliverAux($)
{
    my ($credential) = @_;
    
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "info" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

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

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "bind" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    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'} || 0;

    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!");
    }
    return ShutdownAux($credential, $clear);
}

sub ShutdownAux($$)
{
    my ($credential, $clear) = @_;
    my $slice_uuid = $credential->target_uuid();
    my $user_uuid  = $credential->owner_uuid();
    
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "instantiate" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

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

#
# Return historical data. This is used by the clearinghouse to get stats.
# Currently, only the ClearingHouse will be allowed to make this call.
#
sub ListHistory($)
{
    my ($argref) = @_;
    my $cred     = $argref->{'credential'};
    my $type     = $argref->{'type'};

    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 @tickets;
    if (GeniUsage->ListTickets(\@tickets) != 0) {
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    my @result = ();

    foreach my $ticket (@tickets) {
	my $blob = {"owner_hrn"  => $ticket->{'owner_hrn'},
		    "slice_hrn"  => $ticket->{'slice_hrn'},
		    "created"    => $ticket->{'created'},
		    "redeemed"   => $ticket->{'redeemed'},
		    "expired"    => $ticket->{'expired'},
		    "released"   => $ticket->{'released'},
		    "rspec"      => $ticket->{'rspec_string'}};

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

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "info" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    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 %detailsNew = ();
    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->uuid();
	my $node = LookupNode($node_uuid);
	if (!defined($node)) {
	    $slice->UnLock();
	    print STDERR "Cannot find node by uuid $node_uuid\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	my $hrn = GeniHRN::Generate($OURDOMAIN, "sliver", $node->node_id());

	if ($node->IsUp()) {
	    $details{$node_uuid} = "ready";
	    $detailsNew{$hrn}    = "ready";
	}
	elsif ($node->eventstate() eq TBDB_NODESTATE_TBFAILED()) {
	    $details{$node_uuid} = "failed";
	    $detailsNew{$hrn}    = "failed";
	    $summary = "failed";
	}
	else {
	    $details{$node_uuid} = "notready";
	    $detailsNew{$hrn}    = "notready";
	    $summary = "notready";
	}
    }
    $slice->UnLock();
    my $blob = {"status"  => $summary,
		"details" => \%details,
		"detailsNew" => \%detailsNew,
	       };
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
}

#
# Get the ticket/manifest for a sliver.
#
sub SliverTicket($)
{
    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");
    }
    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!");
    }

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "info" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

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

    my $user = GeniUser->Lookup($user_uuid, 1);
    if (!defined($user)) {
	print STDERR "Could not locate user $user_uuid\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No user found");
    }
    my $aggregate = GeniAggregate->Lookup($sliver_uuid);
    if (!defined($aggregate)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No such sliver here");
    }
    if ($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();
    }
    my $query_result =
	DBQueryWarn("select manifest from geni_manifests ".
		    "where slice_uuid='$slice_uuid'");
    if (!$query_result || !$query_result->numrows) {
	print STDERR "Could not locate manifest for $slice/$aggregate\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    my $row = $query_result->fetchrow_hashref();
    my $rspec =
	eval { XMLin($row->{'manifest'}, KeyAttr => [],
		     ForceArray => ["node", "link", "interface",
				    "interface_ref", "linkendpoints"]) };
    if ($@) {
	print STDERR "XMLin error reading manifest: $@\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    #
    # Update the returned ticket to reflect the current expiration time.
    #
    $rspec->{'valid_until'} =
	POSIX::strftime("20%y-%m-%dT%H:%M:%S",
			gmtime(str2time($slice->expires())));

    my $rspec_xml =
	eval { XMLout($rspec, "NoAttr" => 1, RootName => "rspec") };
    if ($@) {
	print STDERR "XMLout error on manifest to rspec: $@\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

    #
    # Create a new ticket.
    #
    my $ticket = GeniTicket->Create($authority, $user, $rspec_xml);
    if (!defined($ticket)) {
	print STDERR "Could not create new ticket for $slice/$aggregate\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create Ticket");
    }
    if ($ticket->Sign()) {
	print STDERR "Could not sign new ticket $ticket\n";
	# Delete, not Release (which frees nodes).
	$ticket->Delete(TICKET_PURGED);
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not sign Ticket");
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $ticket->asString());
}

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

    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "info" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    #
    # 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 %detailsNew = ();
    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->uuid();
	my $node = LookupNode($node_uuid);
	if (!defined($node)) {
	    $slice->UnLock();
	    print STDERR "Cannot find node by uuid $node_uuid\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	my $hrn = GeniHRN::Generate($OURDOMAIN, "sliver", $node->node_id());

	if ($node->IsUp()) {
	    $details{$node_uuid} = "ready";
	    $detailsNew{$hrn}    = "ready";
	}
	elsif ($node->eventstate() eq TBDB_NODESTATE_TBFAILED()) {
	    $details{$node_uuid} = "failed";
	    $detailsNew{$hrn}    = "failed";
	    $summary = "failed";

	    my $bootlog;
	    my $nodeid = $node->node_id();
	    if ($node->GetBootLog(\$bootlog) == 0) {
		print STDERR "\n\n";
		print STDERR "--------------- $nodeid BootLog -------------\n";
		print STDERR "$bootlog\n";
	    }
	}
	else {
	    $details{$node_uuid} = "notready";
	    $detailsNew{$hrn}    = "notready";
	    $summary = "notready";
	}
    }
    $slice->UnLock();
    my $blob = {"status"  => $summary,
		"details" => \%details,
		"detailsNew" => \%detailsNew,
	       };
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
}

#
# Return a list of unredeemed tickets.
#
sub ListTickets($)
{
    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!");
    }
    my $user_uuid = $credential->owner_uuid();
    my $user = GeniUser->Lookup($user_uuid, 1);
    if (!defined($user)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No such user found");
    }

    #
    # A plain credential issued to a user lets that user get a list
    # of his own tickets. At some point allow the clearinghouse to
    # get more data.
    #
    my @tickets;
    if (GeniTicket->ListUserTickets($user, \@tickets) != 0) {
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    my @result = ();

    foreach my $ticket (@tickets) {
	# Convert to GMT.
	my $expires =
	    POSIX::strftime("20%y-%m-%dT%H:%M:%S",
			    gmtime(str2time($ticket->redeem_before())));
	
	my $blob = {"uuid"           => $ticket->ticket_uuid(),
		    "expires"        => $expires,
		    "redeem_before"  => $expires,
		    
		};
	push(@result, $blob);
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@result);
}

#
# 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";
    my $slice_uuid = $slice->uuid();
    my $experiment = $slice->GetExperiment();

    if (defined($experiment)) {
	my $pid = $experiment->pid();
	my $eid = $experiment->eid();
	
	system("$SNMPIT -r $pid $eid");
	if ($?) {
	    print STDERR "Could not tear down vlans\n";
	    return -1;
	}

	#
	# A firewalled slice gets special treatment.
	#
	if ($slice->needsfirewall()) {
	    print "Calling undoFWNodes ...\n";
	    
	    if (undoFWNodes($experiment, 1) != 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 see if there is an unredeemed ticket.
    #
    my $ticket = GeniTicket->SliceTicket($slice);
    if (defined($ticket)) {
	if ($ticket->Lock() != 0) {
	    print STDERR "CleanupDeadSlice: Could not lock $ticket\n";
	    return -1;
	}
	if ($ticket->Release(TICKET_PURGED)) {
	    print STDERR "CleanupDeadSlice: Could not release $ticket\n";
	    return -1;
	}
    }

    DBQueryWarn("delete from geni_manifests ".
		"where slice_uuid='$slice_uuid'");

    if (defined($experiment)) {
	# These are not serious errors.
	if (system("$EXPORTS_SETUP")) {
	    print STDERR "$EXPORTS_SETUP failed\n";
	}
	if (system("$NAMEDSETUP")) {
	    print STDERR "$NAMEDSETUP failed\n";
	}
    }

    return 0
	if (!$purge);

    if (defined($experiment)) {
	my @pnodes = $experiment->NodeList(1, 1);
	my $pnodes = scalar(@pnodes);
	# Ignore the firewall node in this test; released in endexp.
	$pnodes--
	    if ($slice->needsfirewall());
	if ($pnodes != 0) {
	    print STDERR "There were still nodes allocated to $experiment!\n";
	    # Do this so that a full swapout is done.
	    $experiment->SetState(EXPTSTATE_ACTIVE());
	}
	$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 Blue\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->SetState(EXPTSTATE_SWAPPED());
	$experiment->Update({"geniflags" => $Experiment::EXPT_GENIFLAGS_EXPT});
    }
    return $experiment;
}

sub CreateTicket($)
{
    my ($self) = @_;
    return CreateRspec($self);
}

sub CreateManifest($)
{
    my ($self) = @_;
    return CreateRspec($self);
}

sub CreateRspec($)
{
}

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