#!/usr/bin/perl -wT
#
# GENIPUBLIC-COPYRIGHT
# Copyright (c) 2008-2012 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 ( );

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 GeniXML;
use GeniUsage;
use libtestbed;
use emutil;
use EmulabConstants;
use libEmulab;
use Lan;
use Experiment;
use NodeType;
use English;
use Data::Dumper;
use XML::Simple;
use XML::LibXML;
use Date::Parse;
use POSIX qw(strftime tmpnam);
use Time::Local;
use Compress::Zlib;
use File::Temp qw(tempfile);
use MIME::Base64;
use Digest::SHA1 qw(sha1_hex);

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
my $MAINSITE       = @TBMAINSITE@;
my $ELABINELAB     = @ELABINELAB@;
my $PGENIDOMAIN    = "@PROTOGENI_DOMAIN@";
my $PROTOUSER 	   = "elabman";
my $CREATEEXPT     = "$TB/bin/batchexp";
my $ENDEXP         = "$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 $IPASSIGN       = "$TB/libexec/ipassign_wrapper";
my $TARFILES_SETUP = "$TB/bin/tarfiles_setup";
my $MAPPER         = "$TB/bin/mapper";
my $VTOPGEN        = "$TB/bin/vtopgen";
my $SNMPIT         = "$TB/bin/snmpit_test";
my $RESERVEVLANS   = "$TB/sbin/protogeni/reservevlans";
my $NEWGROUP       = "$TB/bin/newgroup";
my $NEWPROJECT     = "$TB/sbin/newproj";
my $MAKEPROJECT    = "$TB/sbin/mkproj";
my $PRERENDER      = "$TB/libexec/vis/prerender";
my $SUDO           = "/usr/local/bin/sudo";
my $WAP            = "$TB/sbin/withadminprivs";
my $XMLLINT	   = "/usr/local/bin/xmllint";
my $ADDAUTHORITY   = "$TB/sbin/protogeni/addauthority";
my $EMULAB_PEMFILE = "@prefix@/etc/genicm.pem";
my $TARINSTALL     = "/usr/local/bin/install-tarfile";
my $FWNAME	   = "fw";
my $API_VERSION    = 1;
my $USELOCALPROJ   = 0;

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

#
# 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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    if ($type eq "node") {
	require Interface;
	my $node;
	
	if (defined($uuid)) {
	    $node= GeniUtil::LookupNode($uuid);
	}
	else {
	    $node= GeniUtil::LookupNode($hrn);
	}
	if (! defined($node)) {
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED,
					undef, "Nothing here by that name");
	}

	my $rspec = GetAdvertisement(0, $node->node_id(), "0.1", undef);
	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"     =>
			 GeniUtil::FindHostname($node->node_id()),
		     "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 $credstr   = $argref->{'credential'};
    my $available = $argref->{'available'} || 0;
    my $compress  = $argref->{'compress'} || 0;
    my $version   = $argref->{'rspec_version'} || undef;

    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

    return DiscoverResourcesAux($available,
				$compress, $version, [$credential]);
}
# Helper function for V2.
sub DiscoverResourcesAux($$$$)
{
    my ($available, $compress, $version, $credentials) = @_;
    my $user_urn  = $ENV{'GENIRN'};
    $version   = "2"
	if (!defined($version));

    # Sanity check since this can come from client.
    if (! ($version eq "0.1" || $version eq "0.2" || $version eq "2"
	   || $version eq "3"
	   || $version eq "PG 0.1" || $version eq "PG 0.2"
	   || $version eq "PG 2")) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper version request");
    }

    # 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 (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
	      # Cannot get the value, say no.
	      $allow_externalusers = 0;
    }

    # Figure out if user has a credentials that exempts him
    # from the following policy. If external users are blocked access
    # and he presents a credential that exempts him from it, 
    # then he should get access.
    my $isExempted = 0;
    foreach my $credential (@$credentials) {
        if (GeniXML::PolicyExists('allow_externalusers', $credential) == 1) {
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted) {
	my $user = GeniUser->Lookup($user_urn, 1);
	# No record means the user is remote.
	if (!defined($user) || !$user->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
					"External users temporarily denied");
	}
    }

    #
    # See if one of the credentials is a slice credential. If it is, and
    # that slice is active, pass it to ptopgen so that it includes the current
    # resources as available.
    #
    my $experiment = undef;
    foreach my $credential (@$credentials) {
	my ($auth, $type, $id) = GeniHRN::Parse($credential->target_urn());
	if ($type eq "slice") {
	    # Might not exist here yet.
	    my $slice = GeniSlice->Lookup($credential->target_urn());
	    if (defined($slice)) {
		# See if the local experiment exists yet.
		$experiment = Experiment->Lookup($slice->uuid());
	    }
	    last;
	}
    }

    #
    # Acquire the advertisement from ptopgen and compress it if requested.
    #
    my $xml = GetAdvertisement($available, undef, $version, $experiment);
    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, $version, $experiment) = @_;
    my $xml = undef;
    my $gotlock = 0;
    my $filename = "/var/tmp/protogeni_resources.xml";

    $version = "0.1"
	if ($version eq "PG 0.1");
    $version = "0.2"
	if ($version eq "PG 0.2");
    $version = "2"
	if ($version eq "PG 2");

    my $invocation = "$PTOPGEN -x -g $version -r -p GeniSlices";
    if (defined($experiment)) {
	my $eid = $experiment->eid();
	$invocation .= " -e $eid";
    }
    $invocation .= " -a" unless $available;
    if (defined($pc)) {
	$invocation .= " -1 $pc";
    }
    if (!defined($pc)) {
      again:
	#
	# Grab a global script lock. This will ensure that only one ptopgen
	# runs at a time, and everyone else who comes along while that first
	# one is running, will share the same results file.
	#
	# Need to use a well known name, unless we want to share that name
	# via the DB. Lets be simple about it for now.
	#
	if ((my $locked = TBScriptLock("discover", 1)) != TBSCRIPTLOCK_OKAY()) {
	    if ($locked == TBSCRIPTLOCK_IGNORE) {
		#
		# Previous locker finished ptopgen.
		# Grab the file if it exists (small race), otherwise
		# try again from the top.
		#
		if (open(AVAIL, "$filename")) {
		    $xml = "";
		    while (<AVAIL>) {
			$xml .= $_;
		    }
		    close(AVAIL);
		    return $xml;
		}
		goto again;
	    }
	    else {
		print STDERR "Could not get ptopgen lockfile\n";
		return undef;
	    }
	}
	else {
	    #
	    # We got the lock so we get to run ptopgen.
	    #
	    $gotlock = 1;
	}
    }
    if (open(AVAIL, "$invocation |")) {
	$xml = "";
	while (<AVAIL>) {
	    $xml .= $_;
	}
	close(AVAIL);
    }
    #
    # The lock holder has to create the new version of the file for
    # anyone waiting. Need to do this atomically so that anyone still
    # reading the previous version does not get inconsistent data.
    #
    if ($gotlock) {
	my ($fh, $tempname) = tempfile(UNLINK => 0, DIR => "/var/tmp");
	if (!defined($fh)) {
	    print STDERR "Could not create temporary file: $!\n";
	    $xml = undef;
	}
	else {
	    print $fh $xml;
	    close($fh);
	    if (! rename($tempname, $filename)) {
		print STDERR "Could not rename temporary file: $!\n";
		$xml = undef;
	    }
	}
	TBScriptUnlock();
    }
    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 = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

    if ($isupdate) {
	$ticket = CheckTicket($tickstr);
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
    }
    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_urn = $credential->target_urn();
    my $user_urn  = $credential->owner_urn();
    
    #
    # Create user from the certificate.
    #
    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));

    # Bump activity. Does not matter if request fails ...
    $user->BumpActivity();
    
    #
    # Create slice from the certificate.
    #
    my $slice = GeniSlice->Lookup($slice_urn);
    if (!defined($slice)) {
	if ($isupdate) {
	    print STDERR "Could not locate slice $slice_urn for Update\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No slice found for UpdateTicket");
	}
	$slice = CreateSliceFromCertificate($credential, $user);
	return $slice
	    if (GeniResponse::IsResponse($slice));
    }
    
    return GetTicketAuxAux($slice, $user, $rspecstr,
			   $isupdate, $impotent, $v2, $level, $ticket,
			   [$credential]);
}
sub GetTicketAuxAux($$$$$$$$$)
{
    my ($slice, $user, $rspecstr, 
        $isupdate, $impotent, $v2, $level, $ticket, $credentials) = @_;
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
    require OSinfo;
    require VirtExperiment;

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

    #
    # Run xmllint on the rspec to catch format errors.
    #
    my ($fh, $filename) = tempfile(UNLINK => 0);
    if (!defined($fh)) {
	print STDERR "Could not create temp file for rspec\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    print $fh $rspecstr;
    close($fh);
    my $xmlerrors = `$XMLLINT --noout $filename 2>&1`;
    unlink($filename);
    if ($?) {
	return GeniResponse->Create(GENIRESPONSE_ERROR,
				    $xmlerrors,
				    "rspec is not well formed");
    }

    my $rspec = GeniXML::Parse($rspecstr);
    if (! defined($rspec)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Error Parsing rspec XML");
    }

    my $rspecVersion = GeniXML::GetXmlVersion($rspec);
    if (! defined($rspecVersion)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Unknown RSpec Version");
    }

    #
    # A sitevar controls whether external users can get any nodes.
    #
    my $allow_externalusers = 0;
    if (!GetSiteVar('protogeni/allow_externalusers', \$allow_externalusers)){
	    # Cannot get the value, say no.
	    $allow_externalusers = 0;
    }

    # Figure out if user has a credentials that exempts him
    # from the following policy. If external users are blocked access
    # and he presents a credential that exempts him from it, 
    # then he should get access.
    my $isExempted = 0;
    foreach my $credential (@$credentials) {
      if (1 == GeniXML::PolicyExists('allow_externalusers', $credential)) {
        $isExempted = 1;
        last;
      }
    }

    if (!$allow_externalusers && !$isExempted && !$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 nothing specified in the rspec, then it will expire when the
    # slice record expires, which was given by the expiration time of the
    # slice credential, or the local policy max_sliver_lifetime. See
    # CreateSliceFromCertificate() in this file.
    #
    my $expires = GeniXML::GetExpires($rspec);
    if (defined($expires)) {
	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?
	# A sitevar controls the sliver lifetime.
	#
	my $max_sliver_lifetime = 0;
	if (!GetSiteVar('protogeni/max_sliver_lifetime',
			\$max_sliver_lifetime)){
	    # Cannot get the value, default it to 90 days.
	    $max_sliver_lifetime = 90;
	}

	# Check if the user has a credential that lets him obtain slivers
	# with extended sliver lifetime. If so allow him to get sliver.
	foreach my $credential (@$credentials) {
	    my $nodes = GeniXML::FindNodesNS("//n:max_sliver_lifetime",
					     $credential->extensions(),
					     $GeniUtil::EXTENSIONS_NS);
	    if ($nodes->size > 0) {
		$max_sliver_lifetime = int($nodes->pop()->string_value);
		last;
	    }
	}
	my $diff = $when - time();
	if ($diff < (60 * 5)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"such a short life for a sliver? ".
					"More time please.");
	}
	elsif ($diff > (3600 * 24 * $max_sliver_lifetime)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			"expiration is greater then the maximum number ".
			"of minutes " . (60 * 24 * $max_sliver_lifetime));
	}

	#
	# Must be before the slice expires.
	#
	my $slice_expires = $slice->expires();
	if (defined($slice_expires)) {
	    $slice_expires = str2time($slice_expires);
	    if ($when > $slice_expires) {
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "valid_until is past slice expiration");
	    }
	}
    }

    #
    # Lock the ticket so it cannot be released.
    #
    if (defined($ticket) && $ticket->stored() && $ticket->Lock() != 0) {
	return GeniResponse->BusyResponse("ticket");
    }
    if (defined($ticket)) {
	$ticket->SetSlice($slice);
    }
    
    #
    #
    # 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");
    }
    # Ditto for expired.
    if ($slice->IsExpired()) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket) && $ticket->stored());
	return GeniResponse->Create(GENIRESPONSE_REFUSED, undef,
				    "Slice has expired");
    }

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

    #
    # We need this now so we can form a virtual topo.
    #
    my $slice_experiment = GeniExperiment($slice, $user);
    if (GeniResponse::IsResponse($slice_experiment)) {
	$response = $slice_experiment;
	$slice_experiment = undef;
	goto bad;
    }
    my $realuser = FlipToUser($slice, $user);
    if (! (defined($realuser) && $realuser)) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "FlipToUser Error");
	print STDERR "Error flipping to real user\n";
	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.
    #
    my $generated_by = GeniXML::GetText("generated_by", $rspec);
    if (defined($generated_by) &&
	$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);
    $virtexperiment->multiplex_factor(10);

    #
    # Add global vtypes.
    #
    my $vtypes_result =
	emdb::DBQueryWarn("select * from global_vtypes");
    if (!$vtypes_result) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR);
	goto bad;
    }
    while (my $row = $vtypes_result->fetchrow_hashref()) {
	$virtexperiment->NewTableRow("virt_vtypes",
				     {"name"     => $row->{'vtype'},
				      "members"  => $row->{'types'},
				      "weight"   => $row->{'weight'}
				     });
    }

    # Need to move this someplace else; the parser adds a bunch.
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "ns",
				  "objecttype" => "6"});

    #
    # 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 %iface2node = ();
    my %vportmap = ();
    my %nodemap  = ();
    my %bridgemap= ();
    my @nodeids  = ();
    my %lannodes = ();
    # For stitching, keep track of external nodes and links.
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
    my %stitching_paths   = ();

    #
    # 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 (GeniXML::FindNodes("n:node",
					    $oldrspec)->get_nodelist()) {
	    # Let remote nodes pass through.
	    next
		if (!GeniXML::IsLocalNode($ref));

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

	    my $node_nickname = GeniXML::GetVirtualId($ref);
	    my $colocate      = GeniXML::GetColocate($ref);
	    my $component_id  = GeniXML::GetNodeId($ref);
	    my $vnode_id      = GeniXML::GetVnodeId($ref);
	    my $node = GeniUtil::LookupNode($vnode_id);
	    if (!defined($node)) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Bad resource $component_id in ticket");
		goto bad;
	    }
	    #
	    # Is the node a virtual node? Must be an update to an
	    # existing sliver/ticket, since we now return the node_id
	    # of the allocated virtual node, not the physical node.
	    #
	    if ($node->isvirtnode()) {
		my $pnode = Node->Lookup($node->phys_nodeid());
		if (!defined($pnode)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "No physical resource for $component_id");
		    goto bad;
		}
		$node = $pnode;
	    }
	    $namemap{$node_nickname} = $node;
	    $colomap{$colocate} = $node
		if (defined($colocate));
	}
    }

    print GeniXML::Serialize($rspec);

    my %nodeexistsmap = ();

    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
	my $component_id  = GeniXML::GetNodeId($ref);
	my $vnode_id      = GeniXML::GetVnodeId($ref);
	my $manager_id    = GeniXML::GetManagerId($ref);
	my $node_nickname = GeniXML::GetVirtualId($ref);
	my $colocate      = GeniXML::GetColocate($ref);
	my $subnode_of    = GeniXML::GetSubnodeOf($ref);
	my $virtualization_type = GeniXML::GetVirtualizationType($ref);
	
	my $virtualization_subtype
                          = GeniXML::GetVirtualizationSubtype($ref);
	my $exclusive     = GeniXML::GetExclusive($ref);
	my $tarfiles      = GeniXML::GetTarball($ref);
	my $pctype;
	my ($osname, $osinfo);
	my $parent_osname;
	my $node;
	my $isbridge    = 0;
	my $isfirewall  = 0;
	
	if (exists($nodeexistsmap{$node_nickname})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate node $node_nickname");
	    goto bad;
	}
	$nodeexistsmap{$node_nickname} = 1;

	# Always populate iface2node mapping, even if we let the node
	# pass through.
	foreach my $linkref (GeniXML::FindNodes("n:interface",
						$ref)->get_nodelist()) {
	    my $virtual_id   = GeniXML::GetInterfaceId($linkref);
	    if (exists($iface2node{$virtual_id})) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Duplicate interface $virtual_id on ".
					 "node $node_nickname");
		goto bad;
	    }
	    $iface2node{$virtual_id} = $node_nickname;
	}

	# Let remote nodes pass through.
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}

	#
	#
	# 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 (GeniXML::IsLanNode($ref)) {
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

	#
	# Check for disk_image request. Specified as a URN. 
	#
	my $diskref = GeniXML::GetDiskImage($ref);
	if (defined($diskref)) {
	    my $dname = GeniXML::GetText("name", $diskref);

	    if (defined($dname)) {
		if (! GeniHRN::IsValid($dname)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
		my ($auth,$type,$id) = GeniHRN::Parse($dname);
		my ($ospid,$os) = ($id =~ m{(.*)//(.*)});
		if ($type ne "image" || !defined($ospid) || !defined($os)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Malformed image URN: $dname");
		    goto bad;
		}
		$osinfo = OSinfo->Lookup($ospid, $os);
		if (!defined($osinfo)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Unknown image URN: $dname");
		    goto bad;
		}
		#
		# The OS must be in the current project, or it must
		# be global (okay, shared).
		#
		if (! ($osinfo->shared() ||
		       $osinfo->pid() eq $slice_experiment->pid())) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Insufficient permission to use $osinfo");
		    goto bad;
		}
		
		#
		# This is only going to be used in raw mode. 
		#
		$osname = "$ospid/$os";
	    }
	}

	if (defined($virtualization_type)) {
	    if ($virtualization_type eq "emulab-vnode") {
		if (defined($virtualization_subtype)) {
		    $pctype = "pcvm";
		    
		    if ($virtualization_subtype eq "emulab-jail") {
			$osname = "FBSD-JAIL";
		    }
		    elsif ($virtualization_subtype eq "emulab-openvz") {
			# Allow caller to set the image to use, but also
			# trick to set the parent. 
			if (defined($osinfo)) {
			    if (! $osinfo->IsSubOS()) {
				$parent_osname = $osname;
				$osname = "OPENVZ-STD";
			    }
			}
			else {
			    $osname = "OPENVZ-STD";
			}
		    }
		    elsif ($virtualization_subtype eq "emulab-spp") {
			$osname = "SPPVM-FAKE";
			$pctype = "sppvm";
			# Lets force to shared node.
			if (! GeniXML::SetExclusive($ref, 0)) {
			    $response
				= GeniResponse->Create(GENIRESPONSE_BADARGS,
						       undef,
				       "Malformed rspec: ".
				       "Cannot set exclusive tag to false");
			    goto bad;
			}
			$exclusive = 0;
			# Kludge for libvtop.
			$virtexperiment->multiplex_factor(1);
			$virtexperiment->encap_style("vlan");
		    }
		    elsif ($virtualization_subtype eq "emulab-bbg") {
			$osname = "BBGENIVM-FAKE";
			$pctype = "bbgenivm";
			# Lets force to shared node.
			GeniXML::SetExclusive($ref, 0);
			$exclusive = 0;
			$virtexperiment->multiplex_factor(5);
			$virtexperiment->encap_style("vlan");
		    }
		    elsif ($virtualization_subtype eq "raw"
			   || $virtualization_subtype eq "raw-pc") {
			$pctype = undef;
			goto raw;
		    }
		    elsif ($virtualization_subtype eq "delay") {
			$isbridge = 1;
			$pctype   = undef;
		    }
		    elsif ($virtualization_subtype eq "firewall") {
			$isfirewall = 1;
			$osname     = "FW-IPFW2";
			$pctype     = "pc";
			goto raw;
		    }
		    else {
			$response
			    = GeniResponse->Create(GENIRESPONSE_BADARGS,
						   undef,
				       "Malformed rspec: ".
				       "Unknown virtualization_subtype");
			goto bad;
		    }
		}
		else {
		    goto raw;
		}
	    }
	    else {
	      raw:
		# Lets force to exclusive real node.
		if (! GeniXML::SetExclusive($ref, 1)) {
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
			"Malformed rspec: Cannot set exclusive tag to true");
		    goto bad;
		}
		$exclusive = 1;
		my $subtype = "raw-pc";
		if (GeniXML::IsVersion0($ref)) {
		    $subtype = "raw";
		}
		if (! GeniXML::SetVirtualizationSubtype($ref, $subtype)) {
		    $response = GeniResponse->Create(GENIRESPONSE_BADARGS,
						     undef,
			"Malformed rspec: Cannot set virtualization_type to raw");
		    goto bad;
		}
	    }
	}
	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($component_id) || $component_id eq "*") {
	    if (defined($colocate) && exists($colomap{$colocate})) {
		$node = $colomap{$colocate};
	    }
	    elsif ($isupdate && exists($namemap{$node_nickname})) {
		$node = $namemap{$node_nickname};
	    }
	    # If the node still isn't bound and doesn't have a pctype,
	    # use the user-specified one.
	    if (GeniXML::IsVersion0($ref)) {
		if (! defined($node) && ! defined($pctype)) {
		    my $usertype = GeniXML::FindFirst("n:node_type", $ref);
		    if (defined($usertype)) {
			$pctype = GeniXML::GetText("type_name", $usertype);
		    }
		}
	    } else {
		my $usertype = GeniXML::FindFirst("n:hardware_type", $ref);
		if (defined($usertype)) {
		    #
		    # Watch for pcvm type set above. If the user specified
		    # a hardware type for their VMs, then form a proper
		    # hardware specific pcvm type. 
		    #
		    my $pt = GeniXML::GetText("name", $usertype);
		    if (!defined($pt)) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad hardware_type");
			goto bad;
		    }
		    if (defined($pctype) && $pctype eq "pcvm") {
			$pctype = "${pt}-vm";
		    }
		    else {
			$pctype = $pt;
		    }
		}
	    }
	}
	else {
	    $node = GeniUtil::LookupNode($vnode_id);

	    if (!defined($node)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad resource $component_id");
		goto bad;
	    }
	    #
	    # Is the node a virtual node? Must be an update to an
	    # existing sliver/ticket, since we now return the node_id
	    # of the allocated virtual node, not the physical node.
	    #
	    if ($node->isvirtnode()) {
		if (!$isupdate ||
		    !exists($namemap{$node_nickname})) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Bad resource for $node_nickname");
		    goto bad;
		}
		$node = $namemap{$node_nickname};
	    }
	    $pctype = $node->type()
		if (!defined($pctype));
	}

	#
	# If no osname, check for protogeni default osname
	#
	if (! defined($osname)) {
	    my $protogeni_os = undef;
	    if (GetSiteVar('protogeni/default_osname', \$protogeni_os)
		&& $protogeni_os ne ""
		&& (! defined($pctype) || $pctype ne "bbgeni")) {
		$osname = $protogeni_os;
	    }
	}

	#
	# If no osname by this point, try for the default.
	#
	if (defined($node) && !defined($osname)) {
	    if (defined($node->default_osid())) {
		my $default_osinfo = OSinfo->Lookup($node->default_osid());
		$osname = $default_osinfo->osname()
		    if (defined($default_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
			"routertype" => "static-ddijk",
			"fixed"   => (defined($subnode_of) ? $subnode_of :
				      defined($node) ? $node->node_id() : ""),
			    
			};
	
	if (defined($parent_osname)) {
	    $nodeblob->{'parent_osname'} = "$parent_osname";
	}
	if ($isbridge) {
	    $nodeblob->{'role'} = "bridge";
	}
	elsif ($isfirewall) {
	    if ($slice->SetFirewallFlag(1) != 0) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR);
		goto bad;
	    }
	    $nodeblob->{'cmd_line'} = '/kernel.fw';
	    if (!defined($virtexperiment->NewTableRow("virt_firewalls",
						  {"fwname" => $node_nickname,
						   "type"   => "ipfw2-vlan",
						   "style"  => "basic"}))) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Error creating firewall definition");
		goto bad;
	    }
	}
	# Tarball and startup command.
	if (defined($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;
	}
	if (GeniXML::IsVersion0($ref)) {
	    my $startupcmd = GeniXML::GetStartupCommand($ref);
	    if (defined($startupcmd)) {
		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;
	    }
	}
	elsif (my @services = GeniXML::GetServices($ref)) {
	    my $startupCommand = undef;
	    my $startupCount = 0;
	    foreach my $service (@services) {
		if ($service->{'type'} eq "execute") {
		    if ($startupCount == 0) {
			$startupCommand = $service->{'cmd'};
		    }
		    ++$startupCount;
		}
	    }

	    if ($startupCount == 1 && defined($startupCommand)) {
		if (! TBcheck_dbslot($startupCommand, "virt_nodes", "startupcmd",
				TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid startup command");
		    goto bad;
		}
		$nodeblob->{'startupcmd'} = $startupCommand;

	    } else { # BEGIN TEMPORARY ELSE
	    my $count = 0;
	    my $startfile = $slice_experiment->UserDir() .
		"/geni_startup." . $node_nickname;
	    $nodeblob->{'startupcmd'} = $startfile;
	    
	    if (!open(STARTUP, ">$startfile")) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "Error creating startfile");
		goto bad;
	    }
	    print STARTUP "#!/bin/sh\n\n";
	    print STARTUP "# Redirect all output to a file\n";
	    print STARTUP "exec &> /var/tmp/startup.log\n\n";

	    #
	    # It would be nice to interleave "install" with "execute", but
	    # Emulab's tarfiles support arranges to copy the files locally,
	    # and rewrites the names. Need to hook into that support somehow,
	    # but for now tarfiles are all installed as a block above. 
	    #
	    foreach my $service (@services) {
		my $type = $service->{'type'};

		if ($type eq "execute") {
		    my $shell = $service->{'shell'};
		    my $cmd   = $service->{'cmd'};
		    my $log   = "/var/tmp/startup-${count}.txt";
		    my $stat  = "/var/tmp/startup-${count}.status";

		    #
		    # Support only sh and csh. Maybe perl later.
		    #
		    if (! (defined($shell) &&
			   ($shell eq "csh" || $shell eq "sh" ||
			    $shell eq "/bin/csh" || $shell eq "/bin/sh"))) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "Invalid shell in execute");
			goto bad;
		    }
		    if (! ($shell =~ /bin/)) {
			$shell = "/bin/$shell";
		    }
		    print STARTUP "echo -n 'Services execution $count at '\n";
		    print STARTUP "date\n\n";
		    print STARTUP "$shell -c \"$cmd\" >$log 2>&1\n";
		    print STARTUP "status=\$?\n";
		    print STARTUP "echo \"\$status\" > $stat\n";
		    print STARTUP
		      "echo \"Execution $count exited with status \$status\"\n";
		    print STARTUP "echo '----------------------------------'\n";
		    $count++;
		}
	    }
	    print STARTUP "exit 0\n";
	    close(STARTUP);
	    chmod(0755, $startfile);
	    } # END TEMPORARY ELSE
	}

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

	# If the user wants a routable control IP, add this into the database.
	my @routable_control_ip =
	    GeniXML::FindNodesNS("n:routable_control_ip",
				 $ref,
				 $GeniXML::EMULAB_NS)->get_nodelist();

	if (scalar(@routable_control_ip) > 0) {
	    $virtexperiment->NewTableRow("virt_node_attributes",
					 {"vname"   => $node_nickname,
					  "attrkey" => "routable_control_ip",
					  "attrvalue" => "true"});
	}

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

	# Stub program agent.
	$virtexperiment->NewTableRow("virt_programs",
				     {"vnode"   => $node_nickname,
				      "vname"   => "${node_nickname}-program",
				      "command" => "",
				      "dir"     => "",
				      "timeout" => 0,
				      "expected_exit_code" => 0});
	
	$virtexperiment->NewTableRow("virt_agents",
				     {"vnode"     => $node_nickname,
				      "vname"     => "${node_nickname}-program",
				      "objecttype" => "4"});

	# Store reference so we can munge it below. 
	$nodemap{$node_nickname} = {"rspec"    => $ref,
				    "virtnode" => $virtnode,
				    # Grab the type object for later.
				    "nodetype" => NodeType->Lookup($pctype),
	};
	
	#
	# Look for interface forward declarations that will be used later
	# in the link specifications. 
	#
	next
	    if (!defined(GeniXML::FindFirst("n:interface", $ref)));

	foreach my $linkref (GeniXML::FindNodes("n:interface",
						$ref)->get_nodelist()) {
	    my $virtual_id   = GeniXML::GetInterfaceId($linkref);

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

	    my $member = "$node_nickname:$vport";

	    # This is used after the mapper runs since it uses vname:vport.
	    $vportmap{$member} = {"rspec" => $linkref};
	}

	#
	# Look for bridge info.
	#
	if ($isbridge) {
	    my @pipes = GeniXML::GetDelayPipes($ref);
	    if (!@pipes) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "No pipes declared for $node_nickname");
		goto bad;
	    }
	    foreach my $pipe (@pipes) {
		#
		# Might just want a bridge with no shaping, so params
		# might not be defined. 
		#
		my $source   = GetText("source", $pipe);
		my $dest     = GetText("dest", $pipe);
		my $capacity = GetText("capacity", $pipe);
		my $latency  = GetText("latency", $pipe);
		my $lossrate = GetText("lossrate", $pipe);

		# Get the vport we computed above
		if (!exists($ifacemap{$node_nickname}->{$source})) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Pipe specification error");
		    goto bad;
		}
		my $vport = $ifacemap{$node_nickname}->{$source}->{'vport'};

		print STDERR "Bridge: $node_nickname, $source, $dest, $vport\n";

		$bridgemap{$source} = {
		    "name"     => $node_nickname,
		    "dest"     => $dest,
		    "capacity" => $capacity,
		    "latency"  => $latency,
		    "lossrate" => $lossrate,
		    "vport"    => $vport,
		};
	    }
	}
    }

    goto skiplinks
	if (!defined(GeniXML::FindFirst("n:link", $rspec)));

    #
    # Look for a stitching section. The paths are indexed by the id, which
    # will match the client_id in the link.
    #
    foreach my $ref (GeniXML::FindNodesNS("n:stitching",
					  $rspec,
					  $GeniXML::STITCH_NS)->get_nodelist()) {
	foreach my $path (GeniXML::FindNodes("n:path",
					     $ref)->get_nodelist()) {
	    my $path_id = GeniXML::GetText("id", $path);
	    
	    #
	    # Get the hop list and create and create a hash too.
	    #
	    my @hoplist = GeniXML::FindNodes("n:hop",
					     $path)->get_nodelist();
	    my %hophash = ();
	    foreach my $hop (@hoplist) {
		my $hop_id = GeniXML::GetText("id", $hop);
		$hophash{$hop_id} = $hop;
	    }
	    $stitching_paths{$path_id} = { "path"    => $path,
					   "hophash" => \%hophash,
					   "hoplist" => \@hoplist };
	}
    }
    
    #
    # Now deal with links for wildcarded nodes. 
    #
    my $linknum = 1;
    my %linkexistsmap = ();
    
    foreach my $linkref (GeniXML::FindNodes("n:link",
					    $rspec)->get_nodelist()) {
	my $lanname    = GeniXML::GetVirtualId($linkref);
	my $istunnel   = GeniXML::IsTunnel($linkref);
	my @interfaces = GeniXML::FindNodes("n:linkendpoints | ".
					    "n:interface_ref",
					    $linkref)->get_nodelist();
	my %managers   = ();
	my %hops       = ();
	my $ifacenum   = 1;
	my $vindex     = 0;
	my $trivial_ok = 1;
	# Avoid multiple insertions for this setting.
	my $sharedvlansetting = 0;

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

	if (exists($linkexistsmap{$lanname})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate link $lanname");
	    goto bad;
	}
	$linkexistsmap{$lanname} = 1;

	#
	# Look for managers list; optional for now. If not specified then
	# we assume the link is for this CM.
	#
	if (GeniXML::FindNodes("n:component_manager", $linkref)) {
	    %managers = map { GetLinkManager($_) => $_ } 
	                      GeniXML::FindNodes("n:component_manager",
						 $linkref)->get_nodelist();

	    #
	    # Initial check for the entire link. We check on a per interface
	    # case below.
	    #
	    next
		if (!exists($managers{$ENV{'MYURN'}}));
	}

	#
	# Look for hops list; optional.
	#
	if (GeniXML::FindNodes("n:component_hop", $linkref)) {
	    %hops = map { GeniXML::GetNodeId($_) => $_ } 
	                  GeniXML::FindNodes("n:component_hop",
					     $linkref)->get_nodelist();
	}
	

	#
	# 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 = GeniXML::GetInterfaceNodeId($ref);
		if (! GeniXML::IsVersion0($ref)) {
		    my $iface_id = GeniXML::GetInterfaceId($ref);
		    if (defined($iface_id)) {
			$node_nickname = $iface2node{$iface_id};
		    }
		}

		if (defined($node_nickname)
		    && exists($lannodes{$node_nickname})) {
		    $lanname = $node_nickname;
		}
	    }
	    if (!defined($virtexperiment->Find("virt_lan_lans", $lanname))) {
		$virtexperiment->NewTableRow("virt_lan_lans",
					     {"vname" => $lanname});
	    }
	}

	#
	# Sanity check, and determine if the link has any virtnodes
	# in it, cause that is going to change the default bandwidth
	# we use for the entire link or lan.
	#
	# Zero bandwidth acts as a wildcard to assign. But if the
	# link includes any virtual nodes, default to 100Mb since we
	# do not want a VM to consume all available bw unless the user
	# specifically requests it.
	#
	my $default_bandwidth = 0;
	
	foreach my $ref (@interfaces) {
	    my $node_nickname = GeniXML::GetInterfaceNodeId($ref);
	    my $iface_id = GeniXML::GetInterfaceId($ref);

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

	    if (! GeniXML::IsVersion0($ref) && defined($iface_id)) {
		$node_nickname = $iface2node{$iface_id};
	    }

	    if (!defined($node_nickname)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$lanname: Need node id for links");
		goto bad;
	    }
	    my $nodetype = $nodemap{$node_nickname}->{'nodetype'};
	    if (defined($nodetype) && $nodetype->isvirtnode()) {
		# 100Mb
		$default_bandwidth = 100000;
	    }
	}

	foreach my $ref (@interfaces) {
	    my $node_nickname = GeniXML::GetInterfaceNodeId($ref);
	    my $iface_id = GeniXML::GetInterfaceId($ref);
	    my ($iface_ref,$iface_name,$iface_vport);

	    if (! GeniXML::IsVersion0($ref) && defined($iface_id)) {
		$node_nickname = $iface2node{$iface_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_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 the interface refers to a node at another site, then
	    # lets try to stitch together a vlan. Assign will fail if
	    # the user has specified something impossible.
	    #
	    if (exists($external_nodemap{$node_nickname})) {
		if (exists($stitching_paths{$lanname})) {
		    #
		    # The hop path is an ordered list; need to figure out which
		    # end to start at. We want whichever end has he same domain
		    # as us.
		    #
		    my @hoplist = @{ $stitching_paths{$lanname}->{'hoplist'} };
		    my $hopurn  = GetHopLinkID($hoplist[0]);
		    my ($hopauth,undef,undef) = GeniHRN::Parse($hopurn);
		    if ($hopauth ne $OURDOMAIN) {
			# Reverse the list to make life easier.
			@hoplist = reverse(@hoplist);
			$stitching_paths{$lanname}->{'hoplist'} = \@hoplist;
		    }
		    # Make sure the other end is really us. 
		    $hopurn  = GetHopLinkID($hoplist[0]);
		    ($hopauth,undef,undef) = GeniHRN::Parse($hopurn);
		    if ($hopauth ne $OURDOMAIN) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "$lanname: no local path hop");
			goto bad;
		    }
		    #
		    # Go through the hop list to find the edge point. This will
		    # be the first hop that is in a different domain.
		    #
		    my $edgehop;
		    my $lasthop;
		    foreach my $hop (@hoplist) {
			my $hopurn = GetHopLinkID($hop);
			next
			    if (! GeniHRN::IsValid($hopurn));
			
			my ($auth,undef,undef) = GeniHRN::Parse($hopurn);
			next
			    if (!defined($auth));

			if ($auth ne $OURDOMAIN) {
			    $edgehop = $lasthop;
			    last;
			}
			$lasthop = $hop;
		    }
		    if (!defined($edgehop)) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "$lanname: no edge hop");
			goto bad;
		    }
		    #
		    # Look inside the hop urn; it tells the local iface/node
		    # which corresponds to our "fake" nodes.
		    #
		    my $edgeurn = GetHopLinkID($edgehop);
		    my (undef,undef,$edgestuff) = GeniHRN::Parse($edgeurn);
		    my (undef,$ifaceid,$edgenodeid) = split('//', $edgestuff);

		    #
		    # The edge node and the interface on that node must exist.
		    #
		    my $edgenode = Node->Lookup($edgenodeid);
		    if (!defined($edgenode)) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "$lanname: unknown node ".
						 "$edgenodeid in $edgestuff");
			goto bad;
		    }
		    my $edgeiface = Interface->LookupByIface($edgenode,
							     $ifaceid);
		    if (!defined($edgeiface)) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"$lanname: unknown iface in $edgeurn");
			goto bad;
		    }

		    #
		    # Look in the external networks table to get the hop
		    # details. 
		    #
		    my $network = ExternalNetwork->Lookup($edgenodeid);
		    if (!defined($network)) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "$lanname: unknown network for $edgenodeid");
			goto bad;
		    }
		    # Stash for later. We need to allocate a vlan tag, and
		    # this stores the min/max vlan numbers we have to use.
		    $stitching_paths{$lanname}->{'network'} = $network;
		    
		    #
		    # Stick in a reference to the fake node.
		    #
		    my $virtnode =
			$virtexperiment->NewTableRow("virt_nodes",
				    {"vname"   => $node_nickname,
				     "type"    => $network->node_type(),
				     "osname"  => '',
				     "ips"     => '', # deprecated
				     "cmd_line"=> '', # bogus
				     "fixed"   => $edgenode->node_id()});
		    if (!defined($virtnode)) {
			print STDERR "Error creating edge node\n";
			$response = GeniResponse->Create(GENIRESPONSE_ERROR);
			goto bad;
		    }
		    # These nodes are technically shared. 
		    $virtexperiment->NewTableRow("virt_node_desires",
						 {"vname"    => $node_nickname,
						  "desire"   => "pcshared",
						  "weight"   => 0.95});
		    $virtexperiment->encap_style("vlan");
		    $iface_name  = $edgeiface->iface();

		    #
		    # We do this so we can keep track of vport numbers.
		    #
		    if (!exists($external_vportmap{$node_nickname})) {
			$external_vportmap{$node_nickname} = 0;
		    }
		    $iface_vport = $external_vportmap{$node_nickname};
		    $external_vportmap{$node_nickname} += 1;
		    $external_linkmap{$lanname} = $linkref;
		    goto stitch;
		}
		else {
		    $response =
			GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					  "$lanname: No stitching path to ".
					  "$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;
	    }
	    $iface_ref   = $ifacemap{$node_nickname}->{$iface_id}->{"rspec"};
	    $iface_name  = GeniXML::GetText("component_id", $iface_ref);
	    if (!defined($iface_name)) {
		$iface_name = "";
	    }
	    if( GeniHRN::IsValid( $iface_name ) ) {
		my ($urn_authority,$urn_node,$urn_iface) =
		    GeniHRN::ParseInterface( $iface_name );
		$iface_name = $urn_iface;
	    }
	    #
	    # Hack to catch a loopback (trivial link).
	    #
	    if ($iface_name eq "loopback") {
		$iface_name = "";
		$trivial_ok = 1;
	    }
	    $iface_vport = $ifacemap{$node_nickname}->{$iface_id}->{"vport"};

	    my $ip = GeniXML::GetIp($ref, $nodemap{$node_nickname}->{'rspec'});
	    my $mask = GeniXML::GetMask($ref, $nodemap{$node_nickname}->{'rspec'});

	  stitch:
	    # XXX
	    $ip     = "10.10.${linknum}.${ifacenum}" if (!defined($ip));
	    $mask   = "255.255.255.0" if (!defined($mask));
	    my $member    = "$node_nickname:$iface_vport";
	    my $bandwidth = $default_bandwidth;
	    my $latency   = 0.0;
	    my $lossrate  = 0.0;
	    my $estbw     = undef;

	    # Let user override.
	    my $user_bandwidth = GeniXML::GetBandwidth($linkref);
	    if (defined($user_bandwidth)) {
		$bandwidth = $user_bandwidth;
	    }

	    # Look for a link to a bridge.
	    my $bridge_vname = undef;
	    if (exists($bridgemap{$iface_id})) {
		my $bblob = $bridgemap{$iface_id};
		$virtexperiment->NewTableRow("virt_bridges",
					     {"vname" => $bblob->{'name'},
					      "vlink" => $lanname,
					      "vport" => $iface_vport});
		#
		# And then if the bridge is a shaping bridge (delay node).
		#
		if (defined($bblob->{'capacity'})) {
		    $bandwidth = $bblob->{'capacity'};
		}
		# XXX original bw spec goes here for now, for the mapper.
		$estbw = $bandwidth;
		
		$lossrate = $bblob->{'lossrate'}
		    if (defined($bblob->{'lossrate'}));
		$latency = $bblob->{'latency'}
		    if (defined($bblob->{'latency'}));
		$bridge_vname = $bblob->{'name'};
	    }
	    
	    # Watch for shared lans; we have to add the lan entries for them.
	    my $shared_vlan = GeniXML::GetSharedLanName($linkref);
	    if (defined($shared_vlan) && !$sharedvlansetting) {
		# This is the magic for libvtop.
		$virtexperiment->NewTableRow("virt_lan_settings",
					     {"vname"   => $lanname,
					      "capkey"  => "portvlan",
					      "capval"  => $shared_vlan});

		# Clear all this.
		$bandwidth = 0;
		$latency   = 0.0;
		$lossrate  = 0.0;
		$sharedvlansetting = 1;
	    }
	    
	  stitch:	    
	    my $virtlan =
		$virtexperiment->NewTableRow("virt_lans",
					 {"vname"       => $lanname,
					  "vnode"       => $node_nickname,
					  "vport"       => $iface_vport,
					  "vindex"	=> $vindex,
					  "trivial_ok"  => $trivial_ok,
					  "ip"          => $ip,
					  "delay"       => $latency,
					  "bandwidth"   => $bandwidth, # kbps
					  "est_bandwidth" => $estbw,
					  "lossrate"    => $lossrate,
					  "member"      => $member,
					  "mask"        => $mask,
					  "rdelay"      => 0.0,
					  "rbandwidth"  => $bandwidth, # kbps
					  "rest_bandwidth" => $estbw,
					  "rlossrate"   => 0.0,
					  "bridge_vname"=> $bridge_vname,
					  "fixed_iface" => $iface_name});
	    $vportmap{$member}->{"virtlan"} = $virtlan;
	    $ifacenum++;
	    $vindex++;
	}
	$linknum++;
    }
  skiplinks:
    $virtexperiment->Dump();
    {
	#
	# Want to capture this output and return to user.
	#
	my $warnings = "";
	local $SIG{__WARN__} = sub { $warnings .= $_[0] };
	
	if ($virtexperiment->Store()) {
	    print STDERR $warnings
		if ($warnings ne "");
	    
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR,
					     undef, $warnings);
	    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 IP assignment.
    system("$IPASSIGN -d $pid $eid");
    if ($?) {
	$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;
    }
    $slice_experiment->CleanLogFiles();
    
    my $output =
	GeniUtil::ExecQuiet("$MAPPER -a -d -v -u -z -o $tmpfile $pid $eid");
    if ($?) {
	my $logstuff = "";
	
	unlink($tmpfile);
	if ($isupdate) {
	    $slice_experiment->RemovePhysicalState(1);
	    $slice_experiment->RestorePhysicalState();
	}
	#
	# Find the important lines and print them first.
	#
	while ($output =~ /^(.*)$/gm) {
	    my $line = $1;
	    if ($line =~ /^\*\*\* .*$/) {
		$logstuff .= $line;
	    }
	}
	$logstuff .= "\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";
	    $logstuff .= $log;
	}

	# Dump the output to STDERR for debugging.
	print STDERR "----------------------------------------------\n";
	print STDERR "---------------- Mapper Log ------------------\n";
	print STDERR $output;

	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR,
				 "Could not map to resources", $logstuff);
	# So we can find things later.
	$slice_experiment->SaveLogFiles();
	goto bad;
    }
    # Dump the output to STDERR for debugging.
    print STDERR $output;
    
    # So we can find things later.
    $slice_experiment->SaveLogFiles();

    my $solution = GeniXML::ParseFile($tmpfile);
    if ($@) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "XML error in solution");
	goto bad;
    }

    # Check to see if experiment is using more than what is limited by CM.
    # protogeni/max_components sitevar controls number of nodes that can
    # be allocated to an experiment.

    my $max_components = 0;
    if (!GetSiteVar('protogeni/max_components', \$max_components)) {
	      # Cannot get the value, default it to -1. Which means there is no limit.
	      $max_components = -1;
    }

    # Check if the user has a credential that lets him obtain slivers
    # with extended sliver lifetime. If so allow him to get sliver.
    foreach my $credential (@$credentials) {
        my $nodes = GeniXML::FindNodesNS("//n:max_components",
            $credential->extensions(), $GeniUtil::EXTENSIONS_NS);
        if ($nodes->size > 0) {
            $max_components = int($nodes->pop()->getAttribute("limit"));
            last;
        }
    }

    if ($max_components != -1 && $slice_experiment->maximum_nodes() > $max_components) {
        my $message = "Experiment needs nodes(" . $slice_experiment->maximum_nodes()
            . ") that are more than the limit(" . $max_components 
            . ") imposed by CM.";
        print STDERR $message;
        $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
                      $message);
        goto bad;
    }

    unlink($tmpfile);
    print GeniXML::Serialize($solution);

    foreach my $ref (GeniXML::FindNodes("n:node",
					$solution)->get_nodelist()) {
	my $virtual_id     = GeniXML::GetVirtualId($ref);
	my $component_id   = GeniXML::GetNodeId($ref);
	my $vnode_id       = GeniXML::GetVnodeId($ref);

	if (!(exists($nodemap{$virtual_id}) ||
	      exists($external_nodemap{$virtual_id}))) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "Mapper inserted nodes you did not want");
	    goto bad;
	}
	#
	# If this was an external node we placed into the topo, then
	# just skip it. Revisit this later.
	#
	next
	    if (exists($external_nodemap{$virtual_id}));
	
	my $rspec          = $nodemap{$virtual_id}->{'rspec'};
	my $virtnode       = $nodemap{$virtual_id}->{'virtnode'};
	my $node           = GeniUtil::LookupNode($vnode_id);
	my $colocate       = GeniXML::GetColocate($rspec);
	my $subnode_of     = GeniXML::GetSubnodeOf($rspec);

	# Need to do this after the mapper has run.
	$node->Refresh();

	#
	# Regardless of whether the user asked for an exclusive node
	# or not, we have to change the rspec (ticket) to reflect
	# that it is a shared node node or not. We do not need to change
	# the virt_nodes entry since exclusive is just a desire. 
	#
	my $exclusive = (defined($node->sharing_mode()) ? "0" : "1");
	
	if (GeniXML::IsVersion0($rspec)) {
	    GeniXML::SetText("component_urn", $rspec,
			     GeniHRN::Generate( $OURDOMAIN, "node",
						$node->node_id() ));
	    GeniXML::SetText("component_uuid", $rspec, $component_id);
	    GeniXML::SetText("component_manager_urn", $rspec, $ENV{'MYURN'});
	    GeniXML::SetText("component_manager_uuid", $rspec, $ENV{'MYUUID'});
	} else {
	    GeniXML::SetText("component_id", $rspec,
			     GeniHRN::Generate( $OURDOMAIN, "node",
						$node->phys_nodeid() ));
	    GeniXML::SetText("component_manager_id", $rspec, $ENV{'MYURN'});
	    my $vnoderef = GeniXML::FindNodesNS("n:vnode", $rspec,
						$GeniXML::EMULAB_NS)->pop();
	    if (! defined($vnoderef)) {
		$vnoderef = GeniXML::AddElement("vnode", $rspec,
						$GeniXML::EMULAB_NS);
	    }
	    GeniXML::SetText("name", $vnoderef, $node->node_id());
	}
	GeniXML::SetExclusive($rspec, $exclusive);

	# 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)) {
	    # Remember, we fix to the physnode not the virtual.
	    $virtnode->fixed(($node->isvirtnode() ?
			      $node->phys_nodeid() : $node->node_id()));
	}

	# New 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 (GeniXML::FindNodes("n:link",
					$solution)->get_nodelist()) {
	my $nickname          = GeniXML::GetVirtualId($ref);
	my @interfaces        = GeniXML::FindNodes("n:interface_ref",
						   $ref)->get_nodelist();

	foreach my $iface_ref (@interfaces) {
	    my $virtual_port_id   = GeniXML::GetInterfaceId($iface_ref);
	    my $virtual_node_id   = GeniXML::GetInterfaceNodeId($iface_ref);

	    if (!defined($virtual_node_id) || !defined($virtual_port_id)) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Virtual node ID or virtual interface ".
						 "ID missing on interface");
		goto bad;
	    }
	    #
	    # If this was an external node we placed into the topo, skip
	    # it here. Below we contact the other CM to coordinate the
	    # vlan reservation.
	    #
	    next
		if (exists($external_nodemap{$virtual_node_id}));

	    my $vportp      = $vportmap{"$virtual_node_id:$virtual_port_id"};
	    my $linkref     = $vportp->{'rspec'};
	    my $virtlan     = $vportp->{'virtlan'};
	    my $component_id = GeniXML::GetText("component_id", $iface_ref);
	    $virtlan->fixed_iface($component_id)
		if (defined($component_id));
	    $component_id = "lo0"
		if (!defined($component_id));
	    if (! GeniXML::SetText("component_id", $linkref, $component_id)) {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Bad XML: Failed to add component_id");
		goto bad;
	    }
	}
    }

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

    #
    # Now contact external CMs to coordinate vlans. 
    #
    foreach my $linkname (keys(%external_linkmap)) {
	my $linkref   = $external_linkmap{$linkname};
	my $network   = $stitching_paths{$linkname}->{'network'};
	my $slice_urn = $slice->urn();
	my $retries   = 10;
	my $chainmode = ($network->node_type() eq "interconnect-vm" ? 1 : 0);
	my $madevlan  = 0;

	#
	# Treemode; just reserve a local tag. Eventually has to deal with
	# specific vlan tag requests.
	#
	if (!$chainmode) {
	    my $tag = VLan::GetReservedVlanTag($slice_experiment, $linkname);
	    if (!defined($tag)) {
		#
		# The point of this is to create the VLan object, just long 
		# enough to get a lanid and a tag assigned. 
		#
		my $vlan = VLan->Lookup($slice_experiment, $linkname);
		if (!defined($vlan)) {
		    $vlan = VLan->Create($slice_experiment, $linkname);
		    if (!defined($vlan)) {
			$response = GeniResponse->Create(GENIRESPONSE_ERROR,
							 undef,
					 "Internal Error creating vlan object");
			goto bad;
		    }
		    $madevlan = 1;
		}
		my $lanid = $vlan->lanid();
		#
		# Look in the network object to get the limits. This is not an
		# efficient way to do this; should put some of this into snmpit.
		#
		my $network = $stitching_paths{$linkname}->{'network'};
		my $mintag  = $network->min_vlan();
		my $maxtag  = $network->max_vlan();
		my @tags    = ();
		while (scalar(@tags) < 20 && $mintag < $maxtag) {
		    my $t = $mintag++;
		    push(@tags, $t)		
			if (VLan->VlanTagAvailable($t));
		}
		if (!@tags) {
		    $vlan->Destroy()
			if ($madevlan);
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not find a free vlan tag for $linkname");
		    goto bad;
		}
		#
		# Do this in "blockmode" so that snmpit does not throw an error
		# if one of the tags is not available.
		#
		print STDERR
		    "Trying to allocate vlan tags for $linkname: @tags\n";
		system("$SNMPIT --blockmode -A ".
		       "$pid $eid $lanid," . join(",", @tags));
		if ($?) {
		    $vlan->Destroy()
			if ($madevlan);
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			"Error trying to reserve a vlan tag for $linkname");
		    goto bad;
		}
		$vlan->Destroy()
		    if ($madevlan);
	    }
	    $tag = VLan::GetReservedVlanTag($slice_experiment, $linkname);
	    if (!defined($tag)) {
		print STDERR "Did not find the reserved tag for $linkname\n";
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not reserve a vlan tag for $linkname");
		goto bad;
	    }
	    print STDERR "Got tag $tag for $linkname\n";
	    print STDERR "$linkref\n";
	    
	    GeniXML::SetText("vlantag", $linkref, $tag);

	    my @hoplist = @{ $stitching_paths{$linkname}->{'hoplist'} };
	    foreach my $hop (@hoplist) {
		my $hopurn = GetHopLinkID($hop);
		my ($auth,undef,undef) = GeniHRN::Parse($hopurn);
		next
		    if (!defined($auth) || $auth ne $OURDOMAIN);

		#
		# Need to change a couple of fields buried down inside. Ick.
		#
		my $tmp = FindFirst("n:link", $hop);
		$tmp = (FindFirst("n:switchingCapabilityDescriptor", $tmp) ||
			FindFirst("n:switchingCapabilityDescriptors", $tmp))
		    if (defined($tmp));
		$tmp = FindFirst("n:switchingCapabilitySpecificInfo", $tmp)
		    if (defined($tmp));
		if (defined($tmp) &&
		    FindFirst("n:switchingCapabilitySpecificInfo_L2sc", $tmp)) {
		    $tmp = FindFirst("n:switchingCapabilitySpecificInfo_L2sc",
				     $tmp)
		}
		if (defined($tmp)) {
		    SetText("vlanRangeAvailability", $tmp, "$tag");
		    SetText("suggestedVLANRange", $tmp, "$tag");
		}
	    }
	    next;	    
	}

	#
	# Chainmode
	#
	while ($retries) {
	    #
	    # Already have a reserved tag? This could happen if the other CM
	    # acted first and talked to this CM before we saw the ticket
	    # request. Or this is an update and we already have tags reserved.
	    #
	    my $tag = VLan::GetReservedVlanTag($slice_experiment, $linkname);
	    last
		if (defined($tag));

	    my ($fh, $filename) = tempfile(UNLINK => 0);
	    if (!defined($fh)) {
		print STDERR "Could not create temp file for rspec\n";
		$response = GeniResponse->Create(GENIRESPONSE_ERROR);
		goto bad;
	    }
	    print $fh GeniXML::Serialize($rspec);
	    close($fh);
	    system("$RESERVEVLANS '$slice_urn' '$linkname' $filename");
	    if ($CHILD_ERROR) {
		unlink($filename);

		#
		# Positive exit value indicates the other side returned busy.
		# This could be for several reasons, not the least of which is
		# that it is trying to stitch the slice at the same time, and
		# this side is deadlocked with the other side.
		#
		# So, lets try to backoff, dropping the stitching lock for a
		# while so that other side can proceed. Once we get the lock
		# back, look to see if we now have a tag (other side was able
		# to proceed). If so we are done, otherwise try again and repeat
		# for a while. 
		#
		if (($CHILD_ERROR >> 8) == 1) {
		    print STDERR "reservevlans for $linkname returned busy, ".
			"will retry in a bit.\n";
		    $slice->StitchUnLock();
		    # random backoff. 
		    sleep(int(rand(20)) + 5);
		    # We should be able to get the lock at some point.
		    for (my $r = 20; $r > 0; $r--) {
			goto again
			    if ($slice->StitchLock() == 0);
			sleep(5);
		    }
		    print STDERR
			"Could not get the stitching lock back. Giving up\n";
		}
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not reserve vlan tags for $linkname");
		goto bad;
	    }
	    else {
		unlink($filename);

		#
		# Need to find out what vlan was assigned.
		#
		$tag = VLan::GetReservedVlanTag($slice_experiment, $linkname);
		if (defined($tag)) {
		    GeniXML::SetText("vlantag", $linkref, $tag);
		    last;
		}
		# This should not happen. 
		print STDERR "Did not find the reserved tag for $linkname\n";
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "Error reserving vlan tag");
		goto bad;
	    }
	    # Try again.
	  again:
	    $retries--;
	}
    }
    
    print GeniXML::Serialize($rspec);

    #
    # 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,
				       GeniXML::Serialize($rspec));
    if (!defined($newticket)) {
	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not create GeniTicket object");
	goto bad;
    }
    $newticket->SetSlice($slice);
    
    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 (@nodeids) {
	    system("export NORELOAD=1; ".
		   "$NFREE -x -q $pid $eid @nodeids");
	}
	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 (@nodeids) {
	    system("export NORELOAD=1; ".
		   "$NFREE -x -q $pid $eid @nodeids");
	}
	#
	# 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 = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

    my $ticket = CheckTicket($ticketstr);
    return $ticket
	if (GeniResponse::IsResponse($ticket));

    # Only unredeemed tickets are stored in the DB.
    if (!$ticket->stored()) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "This ticket was already redeemed!");
    }
    return SliverWorkAux($credential, $ticket,
			 $keys, $isupdate, $impotent, 0, 0);
}

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

    # 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_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;
    
    if ($isupdate) {
	$aggregate = GeniAggregate->Lookup($credential->target_urn());

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

	if (defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Already have an aggregate for slice");
	}
    }
    my $slice_uuid = $slice->uuid();

    $ticket->SetSlice($slice)
	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");
    }
    # Ditto expired slices.
    if ($slice->IsExpired()) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket));
	return GeniResponse->Create(GENIRESPONSE_REFUSED, undef,
				    "Slice has expired");
    }

    #
    # Create the user.
    #
    my $owner = CreateUserFromCertificate($credential);
    return $owner
	if (GeniResponse::IsResponse($owner));

    # Bump activity. Does not matter if request fails ...
    $owner->BumpActivity();

    # And the experiment.
    my $experiment = GeniExperiment($slice, $owner);
    if (GeniResponse::IsResponse($experiment)) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket));
	return $experiment;
    }
    my $realuser = FlipToUser($slice, $owner);
    if (!defined($realuser) || !$realuser) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "FlipToUser Error");
	print STDERR "Error flipping to real user\n";
	goto bad;
    }
    my $pid = $experiment->pid();
    my $eid = $experiment->eid();

    if (defined($keys)) {
	$response = AddKeys($slice, $owner, $keys);
	if (GeniResponse::IsResponse($response)) {
	    $slice->UnLock();
	    $ticket->UnLock()
		if (defined($ticket));
	    return $response;
	}
    }

    # We need this for accounting. 
    $experiment->SetSwapInfo($realuser->emulab_user());

    #
    # 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 %iface2node = ();
    my $needplabslice = 0;
    # For stitching, keep track of external nodes and links.
    my %external_nodemap = ();
    my %external_linkmap = ();

    print GeniXML::Serialize($rspec);

    # The Manifest starts out as a copy of the rspec. 
    my $manifest = $rspec->cloneNode(1);
    if (! GeniXML::IsVersion0($manifest)) {
	GeniXML::SetText("type", $manifest, "manifest");
	my $schemaLocation = GeniXML::FindNodesNS('@n:schemaLocation',
						  $manifest,
						  $GeniXML::XSI_NS)->pop();
	if (defined($schemaLocation) &&
	    $schemaLocation->nodeType() == XML_ATTRIBUTE_NODE) {
	    my $value = $schemaLocation->getValue();
	    my $requestUrl = $GeniXML::REQUEST_2_URL;
	    my $manifestUrl = $GeniXML::MANIFEST_2_URL;
	    $value =~ s/$requestUrl/$manifestUrl/;
	    $requestUrl = $GeniXML::REQUEST_3_URL;
	    $manifestUrl = $GeniXML::MANIFEST_3_URL;
	    $value =~ s/$requestUrl/$manifestUrl/;
	    $schemaLocation->setValue($value);
	}
    }


    #
    # Find current slivers and save.
    #
    if (defined($aggregate)) {
	$oldmanifest = $aggregate->GetManifest(0);
	if (!defined($oldmanifest)) {
	    $message = "Internal error getting manifest";
	    goto bad;
	}
	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. 
    #
    my $expires = GeniXML::GetExpires($rspec);
    if (defined($expires)) {
	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? No, since we actually made this
	# check when we granted the ticket (see above). 
	#
	my $diff = $when - time();
	if ($diff < (60 * 5) || $diff > (3600 * 24 * 100)) {
	    $message = "expiration is out of range";
	    goto bad;
	}

	#
	# Must be before the slice expires.
	#
	my $slice_expires = $slice->expires();
	if (defined($slice_expires)) {
	    $slice_expires = str2time($slice_expires);
	    if ($when > $slice_expires) {
		$message = "valid_until is past slice expiration";
		goto bad;
	    }
	}
	#
	# Seems odd, eh? This changes the slice expiration in the DB,
	# which was originally the time in the slice credential. The slice
	# cannot be extended beyond this point, except by going through
	# the RenewSliver() call below.
	#
	if ($slice->SetExpiration($when) != 0) {
	    $message = "Could not set expiration time";
	    goto bad;
	}
    }

    #
    # Make sure all nodes requested are allocated. 
    #
    foreach my $ref (GeniXML::FindNodes("n:node",
					$rspec)->get_nodelist()) {
	my $resource_id   = GeniXML::GetNodeId($ref);
	my $vnode_id      = GeniXML::GetVnodeId($ref);
	my $node_nickname = GeniXML::GetVirtualId($ref);
	my $manager_id    = GeniXML::GetManagerId($ref);
	
	# Always populate iface2node mapping, even if we let the node
	# pass through.
	foreach my $iface (GeniXML::FindNodes("n:interface",
					     $ref)->get_nodelist()) {
	    my $iface_id = GeniXML::GetInterfaceId($iface);
	    if (defined($iface_id)) {
		$iface2node{$iface_id} = $node_nickname;
	    }
	}

	# Let remote nodes pass through.
	if (! GeniXML::IsLocalNode($ref)) {
	    $external_nodemap{$node_nickname} = $ref;
	    next;
	}

	#
	# 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 (GeniXML::IsLanNode($ref)) {
	    $lannodes{$node_nickname} = $ref;
	    next;
	}

	my $node = GeniUtil::LookupNode($vnode_id);
	if (!defined($node)) {
	    $message = "Bad vnode_id $vnode_id";
	    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 (!$reservation->SameExperiment($experiment)) {
		$message = "$resource_id ($node) is not available";
		goto bad;
	    }
	}
	else {
	    $message = "$resource_id ($node) is not available";
	    goto bad;
	}
	# Unincorporated nodes have no genisliver_idx.
	my $restable = $node->ReservedTableEntry();
	if (defined($restable) &&
	    (!defined($restable->{'genisliver_idx'}) ||
	     $restable->{'genisliver_idx'} == 0)) {
	    $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 (GeniXML::FindNodes("n:node",
					    $rspec)->get_nodelist()) {
	    my $virtual_id = GeniXML::GetVirtualId($ref);
	    if (defined($virtual_id) && $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);
	}
    }

    #
    # 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 (GeniXML::FindNodes("n:link",
						$rspec)->get_nodelist()) {
	    my $nickname = GeniXML::GetVirtualId($linkref);

	    if (defined($nickname) && $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(1)) {
	    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;
    }
    $experiment->CleanLogFiles();

    #
    # The mapper is going to update the resource record, so we have to
    # call PreSwap() first, since it generates a new record. 
    #
    if ($isupdate) {
	$experiment->PreSwap($realuser->emulab_user(),
			     $Experiment::EXPT_SWAPMOD, EXPTSTATE_ACTIVE());
    }
    else {
	$experiment->PreSwap($realuser->emulab_user(),
			     $Experiment::EXPT_SWAPIN, EXPTSTATE_SWAPPED());
    }
    $didpreswap = 1;
    
    # Add -u for update mode, but not -f (fixnode). 
    my $output = GeniUtil::ExecQuiet("$MAPPER -d -v -z -u $pid $eid");
    if ($?) {
	my $logstuff = "";
	$message = "Could not map to resources";

	print STDERR "Mapper failed!\n";
	#
	# Find the important lines and print them first.
	#
	while ($output =~ /^(.*)$/gm) {
	    my $line = $1;
	    if ($line =~ /^\*\*\* .*$/) {
		$logstuff .= $line;
	    }
	}
	$logstuff .= "\n";
	
	#
	# Lets dump the error log, so it ends up in the email.
	#
	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";
	    $logstuff .= $log;
	}
	# 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";
	}	    
	# Dump the output to STDERR for debugging.
	print STDERR "----------------------------------------------\n";
	print STDERR "---------------- Mapper Log ------------------\n";
	print STDERR $output;

	$response =
	    GeniResponse->Create(GENIRESPONSE_ERROR, $message, $logstuff);

	# So we can find things later.
	$experiment->SaveLogFiles();
	goto bad;
    }
    $shouldrollback = 1;
    # Dump the output to STDERR for debugging.
    print STDERR $output;
  
    # So we can find things later.
    $experiment->SaveLogFiles();

    #
    # Must do this after the mapper runs.
    #
    $output = GeniUtil::ExecQuiet("$TARFILES_SETUP -q $pid $eid");
    if ($?) {
	$message = "Could not setup tarfiles:\n$output";
	print STDERR $message;
	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 %ifacexml = ();
    my %rspecmap  = ();
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
	my $resource_id   = GeniXML::GetNodeId($ref);
	my $vnode_id      = GeniXML::GetVnodeId($ref);
	my $virtual_id    = GeniXML::GetVirtualId($ref);
	my $manager_id    = GeniXML::GetManagerId($ref);

	my $inaggregate   = 0;
	my $sliver;

	$rspecmap{$virtual_id} = $ref;

	# Let remote nodes pass through.
	next
	    if (! GeniXML::IsLocalNode($ref));

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

	#
	# For a map of the interfaces.
	#
	foreach my $linkref (GeniXML::FindNodes("n:interface",
						$ref)->get_nodelist()) {
	    my $component_id     = GeniXML::GetText("component_id", $linkref);
	    my $virtual_iface_id = GeniXML::GetInterfaceId($linkref);

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

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

	my $node = GeniUtil::LookupNode($vnode_id);
	if (!defined($node)) {
	    $message = "Unknown vnode_id in ticket: $vnode_id";
	    goto bad;
	}
	# Must do this after mapper has run
	$node->Refresh();

	if (grep {$_ eq $virtual_id} keys(%nodemap)) {
	    #
	    # Already in the aggregate, so reuse sliver.
	    #
	    $inaggregate = 1;
	    $sliver = $nodemap{$virtual_id};
	}
	else {
	    $sliver = GeniSliver::Node->Create($slice, $owner, $node, $ref);
	    if (!defined($sliver)) {
		$message = "Could not create GeniSliver object for $virtual_id";
		goto bad;
	    }
	    $slivers{$sliver->uuid()} = $sliver;
	    $nodemap{$virtual_id} = $sliver;

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

	my $node_manifest = $sliver->AnnotateManifest();
	if (! defined($node_manifest)) {
	    $message = "Could not annotate sliver for $virtual_id";
	    goto bad;
	}

	# And store into the new manifest.
	my $oldnode = GeniXML::GetNodeByVirtualId($virtual_id, $manifest);
	my $newnode = GeniXML::ReplaceNode($oldnode, $node_manifest);

	# If using rspec v2, save the interface xml node for later
	# annotation when iterating through links.
	if (! GeniXML::IsVersion0($newnode)) {
	    foreach my $linkref (GeniXML::FindNodes("n:interface",
						   $newnode)->get_nodelist()) {
		my $virtual_iface_id = GeniXML::GetInterfaceId($linkref);
		$ifacexml{$virtual_iface_id} = $linkref;
	    }
	}
    }

    #
    # 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 (!defined(GeniXML::FindFirst("n:link", $rspec)));
    
    foreach my $linkref (GeniXML::FindNodes("n:link",
					    $rspec)->get_nodelist()) {
	my @linkslivers  = ();
	my $inaggregate  = 0;
	my %managers     = ();
	my $linkname     = GeniXML::GetVirtualId($linkref);
	my @interfaces   = GeniXML::FindNodes("n:linkendpoints | ".
					      "n:interface_ref",
					      $linkref)->get_nodelist();

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

	#
	# Look for managers list; optional for now. If not specified then
	# we assume the link is for thie CM.
	#
	if (GeniXML::FindNodes("n:component_manager", $linkref)) {
	    %managers = map { GeniXML::GetLinkManager($_) => $_ } 
	                      GeniXML::FindNodes("n:component_manager",
						 $linkref)->get_nodelist();

	    #
	    # Initial check for the entire link. We check on a per interface
	    # case below.
	    #
	    next
		if (!exists($managers{$ENV{'MYURN'}}));
	}

	my $is_tunnel = GeniXML::IsTunnel($linkref);

	#
	# If the link is already in the aggregate, we need to regenerate
	# manifest info only.
	#
	if (grep {$_ eq $linkname} keys(%linkmap)) {
	    $inaggregate = 1;
	}

	#
	# XXX Tunnels are a total kludge right now ...
	#
	if ($is_tunnel) {
	    my $tunnel;
	    my $iface1ref   = $interfaces[0];
	    my $iface2ref   = $interfaces[1];
	    my $node1_id    = GeniXML::GetText("virtual_node_id",
					       $iface1ref);
	    my $node2_id    = GeniXML::GetText("virtual_node_id",
					       $iface2ref);
	    if (! GeniXML::IsVersion0($linkref)) {
		my $iface1_id = GeniXML::GetInterfaceId($iface1ref);
		$node1_id = $iface2node{$iface1_id}
		  if (defined($iface1_id));
		my $iface2_id = GeniXML::GetInterfaceId($iface2ref);
		$node2_id = $iface2node{$iface2_id}
		  if (defined($iface2_id));
	    }

	    my $node1sliver;
	    my $node2sliver;
	    my $node1rspec;
	    my $node2rspec;
	    if (defined($node1_id) && defined($node2_id)) {
		$node1sliver = $nodemap{$node1_id};
		$node2sliver = $nodemap{$node2_id};
		$node1rspec  = $rspecmap{$node1_id};
		$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;
	    }
	    
	    print STDERR Dumper([$node1sliver,
				 $node2sliver,
				 Serialize($linkref, 1),
				 Serialize($node1rspec, 1),
				 Serialize($node2rspec, 1)])
		if (0);

	    if ($inaggregate) {
		$tunnel = $linkmap{$linkname};
	    }
	    else {
		$tunnel = GeniAggregate::Tunnel->Create($slice,
							$owner,
							$node1sliver,
							$node2sliver,
							$linkref,
							$node1rspec,
							$node2rspec);
		if (!defined($tunnel)) {
		    $message = "Could not create aggregate for $linkname";
		    goto bad;
		}
		$slivers{$tunnel->uuid()} = $tunnel;
		$linkmap{$linkname} = $tunnel;
	    }
	    
	    # Manifest goes back to the user.
	    if (GeniXML::IsVersion0($linkref)) {
		GeniXML::SetText("sliver_uuid", $linkref, $tunnel->uuid());
		GeniXML::SetText("sliver_urn", $linkref, $tunnel->urn());
	    } else {
		GeniXML::SetText("sliver_id", $linkref, $tunnel->urn());
	    }

	    my @tunnel_slivers = ();
	    if ($tunnel->SliverList(\@tunnel_slivers) != 0) {
		$message = "Could not get slivers for $tunnel\n";
		goto bad;
	    }
	    foreach my $tunnel_sliver (@tunnel_slivers) {
		my $id = GeniXML::GetInterfaceId($tunnel_sliver->rspec());
		my $ifref = $ifacexml{$id};
		if (defined($ifref)) {
		    if (!GeniXML::IsVersion0($linkref)) {
			GeniXML::SetText("sliver_id", $ifref,
					 $tunnel_sliver->sliver_urn());
			GeniXML::SetText("component_id", $ifref,
					 $tunnel_sliver->component_urn());
		    }
		}
		# Find the right interface_ref and update the manifest
		my $tmp = GeniXML::GetElementByVirtualId($id, 'interface_ref',
							 $linkref);
		if ($tmp) {
		    $tunnel_sliver->AnnotateManifest($tmp);
		}
	    }

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

	if ($inaggregate) {
	    $linkaggregate = $linkmap{$linkname};
	}
	else {
	    $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.
	if (GeniXML::IsVersion0($linkref)) {
	    GeniXML::SetText("sliver_uuid", $linkref, $linkaggregate->uuid());
	    GeniXML::SetText("sliver_urn", $linkref, $linkaggregate->urn());
	} else {
	    GeniXML::SetText("sliver_id", $linkref, $linkaggregate->urn());
	}

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

	foreach my $ifaceref (@interfaces) {
	    my $iface_id   = GeniXML::GetInterfaceId($ifaceref);
	    my $node_id    = GeniXML::GetInterfaceNodeId($ifaceref);
	    if (! GeniXML::IsVersion0($ifaceref) && defined($iface_id)) {
		$node_id = $iface2node{$iface_id};
	    }
	    my ($vnode,$vinterface);

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

	    #
	    # If the interface refers to a node at another site, then
	    # we can ignore it. It was just a placeholder for getting
	    # the vlan tag reserved.
	    #
	    if (!exists($nodemap{$node_id}) &&
		exists($external_nodemap{$node_id})) {
		next;
	    }
	    my $nodesliver = $nodemap{$node_id};
	    
	    if (!defined($nodesliver)) {
		$message = "Link $linkname specifies a non-existent node";
		goto bad;
	    }
	    my $node = GeniUtil::LookupNode($nodesliver->resource_id());
	    if (!defined($node)) {
		$message = "Could not find node object for $nodesliver";
		goto bad;
	    }
	    #
	    # Not quite sure how to deal with virtual interfaces yet.
	    # For now, the link section will hold the physical info,
	    # but we have to return the VMAC so the caller knows which
	    # virtual interface.
	    #
	    if ($node->isvirtnode()) {
		$vnode = $node;
		$node  = GeniUtil::LookupNode($vnode->phys_nodeid());
		if (!defined($node)) {
		    $message = "Could not find node object for $nodesliver";
		    goto bad;
		}
		# Must do this after mapper has run
		$node->Refresh();
		
		$vinterface =
		    Interface::VInterface->LookupByVirtLan($experiment,
				     $linkname, $node_id);
	    }
	    else {
		$vinterface =
		    Interface::VInterface->LookupByVirtLan($experiment,
				     $linkname, $node_id);
	    }
	    #
	    # 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") {
		if (GeniHRN::IsValid($iface_name)) {
		    my ($authority, $short_node, $short_iface) =
			GeniHRN::ParseInterface($iface_name);
		    $iface_name = $short_iface;
		}
		$interface = Interface->LookupByIface($node, $iface_name);
		if (!defined($interface)) {
		    $message = "No such interface $iface_name on $node";
		    goto bad;
		}
	    }
	    my $sliver;

	    if ($inaggregate) {
		my $nickname = "$linkname." . $node->node_id() . ".$iface_name";
		$sliver = $linkaggregate->FindSliverByNickname($nickname);

		if (!defined($sliver)) {
		    $message = "Could not find existing sliver for ".
			"$nickname in $linkname";
		    goto bad;
		}
	    }
	    else {
		$sliver = GeniSliver::Interface->Create($slice,
							$owner,
							$node->node_id(),
							$iface_name,
							$linkname,
							$ifaceref);
		if (!defined($sliver)) {
		    $message = "Could not create GeniSliver for ".
			"$iface_name in $linkname";
		    goto bad;
		}
	    }
	    # Initial update of the manifest.
	    $ifaceref = $sliver->AnnotateManifest($ifaceref);
	    my $outref;
	    my $sliverName = "sliver_urn";
	    my $macName = "MAC";
	    my $macAddress = undef;
	    $macAddress = $interface->mac()
		if (defined($interface));
	    my $ipAddress;
	    if (defined($vinterface)) {
		$ipAddress = $vinterface->IP();
	    } else {
		$ipAddress = $interface->IP();
	    }
	    # Manifest goes back to the user.
	    if (GeniXML::IsVersion0($ifaceref)) {
		$outref = $ifaceref;
		GeniXML::SetText("VMAC", $ifaceref, $vinterface->mac())
		    if (defined($vinterface));
		if (defined($ipAddress) && $ipAddress ne "") {
		    GeniXML::SetText("IP", $outref, $ipAddress);
		}
		GeniXML::SetText("component_urn", $ifaceref,
				 $sliver->component_urn());
	    }
	    elsif (exists($ifacexml{$iface_id})) {
		$outref = $ifacexml{$iface_id};
		$sliverName = "sliver_id";
		$macName = "mac_address";
		if (defined($ipAddress) && $ipAddress ne "") {
		    my $child = GeniXML::FindFirst("n:ip", $outref);
		    if (! defined($child)) {
			$child = GeniXML::AddElement("ip", $outref);
		    }
		    GeniXML::SetText("address", $child, $ipAddress);
		    GeniXML::SetText("type", $child, "ipv4");
		}
		GeniXML::SetText($sliverName, $ifaceref,
				 $sliver->sliver_urn());
		GeniXML::SetText("component_id", $outref,
				 $sliver->component_urn());
		GeniXML::SetText("component_id", $ifaceref,
				 $sliver->component_urn());
		if (defined($vinterface)) {
		    $macAddress = $vinterface->mac();
		}
	    }
	    if (defined($outref)) {
		GeniXML::SetText($sliverName, $outref,
				 $sliver->sliver_urn());
		GeniXML::SetText($macName, $outref, $macAddress)
		    if (defined($macAddress));
	    }
	    
	    if (!$inaggregate &&
		$sliver->SetAggregate($linkaggregate) != 0) {
		$message = "Could not add link sliver $sliver to $aggregate";
		goto bad;
	    }
	}
      manifest:
	# And store into the new manifest.
	my $oldlink = GeniXML::GetLinkByVirtualId($linkname, $manifest);
	GeniXML::ReplaceNode($oldlink, $linkref);
	
    }
  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()) {
	require Firewall;

	if ($isupdate) {
	    #
	    # Add new nodes inside the firewall.
	    #
	    if (values(%newnodes)) {
		my @nodeids = map { $_->node_id() } values(%newnodes);

		if (Firewall::doFWlans($experiment,
				       Firewall::FWADDNODES(), \@nodeids)) {
		    print STDERR "FireWall update failed\n";
		    goto bad;
		}
	    }
	}
	elsif (Firewall::doFWlans($experiment, Firewall::FWSETUP(), undef)) {
	    print STDERR "FireWall update 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) {
	require Lan;

	#
	# We want to reserve the vlan tags now so that we can put them
	# into the manifest. Use snmpit for this, since ELABINELAB will
	# need to ask the outer boss for the reserved tags.
	#
	system("$SNMPIT -A $pid $eid");
	if ($?) {
	    $message = "Could not reserve vlan tags";
	    goto bad;
	}
    }
    elsif (!$v2) {
	require Lan;
	
	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;
	}
    }
    foreach my $linkref (GeniXML::FindNodes("n:link",
					    $manifest)->get_nodelist()) {
	my $vname = GeniXML::GetVirtualId($linkref);
	my $vlan;

	my $lan = Lan->Lookup($experiment, $vname, 1);
	if (!defined($lan)) {
	    print STDERR "No lan object for $vname\n";
	    next;
	}
	if ($lan->type() eq "vlan") {
	    $vlan = VLan->Lookup($experiment, $vname);
	}
	elsif (defined($lan->link())) {
	    $vlan = VLan->Lookup($lan->link());
	}
	if (!defined($vlan)) {
	    print STDERR "Could not find a vlan for $vname\n";
	    next;
	}
	my $tag;
	if ($v2) {
	    $tag = $vlan->GetReservedVlanTag();
	}
	else {
	    $vlan->GetTag(\$tag);
	}
	if (!defined($tag)) {
	    print STDERR "No tag for $vlan\n";
	    next;
	}
	GeniXML::SetText("vlantag", $linkref, $tag);
    }
	
    # Set up plab nodes all at once. 
    if ($needplabslice && @plabnodes && !$impotent) {
	my @node_ids = map { $_->node_id() } @plabnodes;

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

    #
    # The API states we return a credential to control the aggregate.
    #
    my $sliver_credential = $aggregate->NewCredential($owner);

    if (!defined($sliver_credential)) {
	$message = "Could not create credential";
	goto bad;
    }

    #
    # Record all manifests (including updates) in the history. 
    #
    if (GeniUsage->NewManifest($aggregate, $manifest, $rspec)) {
	print STDERR "GeniUsage->NewManifest($aggregate) failed\n";
    }
    #
    # Each new aggregate gets a history record.
    #
    if (!$isupdate &&
	GeniUsage->NewAggregate($aggregate, $slice, $owner)) {
	print STDERR "GeniUsage->NewAggregate($aggregate) failed\n";
    }

    # This should move someplace else?
    my $manifest_string = GeniXML::Serialize($manifest);
    DBQueryWarn("replace into geni_manifests set ".
		"  manifest=". DBQuoteSpecial($manifest_string) . ", " .
		"  idx=NULL, slice_uuid='$slice_uuid', created=now()");

    #
    # Cache the credential for subsequent requests. See GetSliver().
    # Okay if this fails.
    #
    if ($isupdate) {
	GeniCredential->DeleteForTarget($aggregate);
    }
    $sliver_credential->Store();
    
    if ($isupdate) {
	$experiment->PostSwap($realuser->emulab_user(),
			      $Experiment::EXPT_SWAPMOD);
    }
    else {
	$experiment->SetState(EXPTSTATE_ACTIVE());
	$experiment->PostSwap($realuser->emulab_user(),
			      $Experiment::EXPT_SWAPIN);
	
	$ticket->Redeem()
	    if (defined($ticket));
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				    [$sliver_credential->asString(),
				     $manifest_string]);
    }
    #
    # Free any slivers that were no longer wanted.
    #
    foreach my $slink (@freelinks) {
	$slink->UnProvision();
	$slink->Delete(0);
    }
    foreach my $snode (@freenodes) {
	$snode->UnProvision();
	$snode->Delete(0);
    }
    $ticket->Redeem()
	if (defined($ticket));
    $aggregate->SetRegistered(0);
    $slice->UnLock();
    if ($v2) {
	return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				    [$sliver_credential->asString(),
				     $manifest_string]);
    } else {
	return GeniResponse->Create(GENIRESPONSE_SUCCESS, $manifest_string);
    }

  bad:
    if ($didpreswap) {
	if ($isupdate) {
	    $experiment->SwapFail($realuser->emulab_user(),
				  $Experiment::EXPT_SWAPMOD, 1);
	}
	else {
	    $experiment->SwapFail($realuser->emulab_user(),
				  $Experiment::EXPT_SWAPIN, 1);
	}
    }
    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 @oldnodeids = map { $_->node_id() } values(%newnodes);
	
	if ($slice->needsfirewall() && $didfwsetup) {
	    if (@oldnodeids &&
		Firewall::doFWlans($experiment, Firewall::FWDELNODES(),
				   \@oldnodeids)) {
		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 (($shouldrollback &&
		 $experiment->ReserveSharedBandwidth(1, 1)) ||
		$experiment->RemovePhysicalState(1) ||
		$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";
	}

	# Remove any residual state.
	if ($experiment->RemovePhysicalState(1)) {
	    print STDERR "Could not remove physical state!\n";
	}
    }
    
    $slice->UnLock();
    $ticket->UnLock()
	if (defined($ticket));
    return $response ||
	GeniResponse->Create(GENIRESPONSE_ERROR, undef, $message);
}

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

    if (! (defined($credstr))) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

    return RenewSliverAux([$credential], $expires);
}

sub RenewSliverAux($$)
{
    my ($credentials, $expires) = @_;
    my $credential  = $credentials->[0];
    my $message     = "Error renewing aggregate";
    my $when;
    
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "control" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    my $slice = GeniSlice->Lookup($credential->target_urn());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local slice found");
    }
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse("slice");
    }
    # Shutdown slices get nothing.
    if ($slice->shutdown()) {
	$message = "Slice has been shutdown";
	goto bad;
    }

    #
    # Figure out new expiration time.
    #
    my $slice_expires = $credential->expires();
    if (!defined($slice_expires)) {
	$message = "No expiration time in credential";
	goto bad;
    }
    # Convert slice expiration to a time.
    my $slice_when = str2time($slice_expires);
    if (!defined($slice_when)) {
	$message = "Could not parse expiration in credential";
	goto bad;
    }

    #
    # A sitevar controls the sliver lifetime.
    #
    my $max_sliver_lifetime = 0;
    if (!GetSiteVar('protogeni/max_sliver_lifetime',
		    \$max_sliver_lifetime)){
	# Cannot get the value, default it to 90 days.
	$max_sliver_lifetime = 90;
    }

    #
    # If no time is specified, then the user says they want to use
    # the time in the slice credential, but must still check that
    # against the local policy. 
    #
    if (defined($expires)) {
	# Convert to a localtime.
	$when = timegm(strptime($expires));
	if (!defined($when)) {
	    $message = "Could not parse expiration";
	    goto bad;
	}

	# Check if the user has a credential that lets him obtain slivers
	# with extended sliver lifetime. If so allow him to get sliver.
	foreach my $credential (@$credentials) {
	    my $nodes = GeniXML::FindNodesNS("//n:max_sliver_lifetime",
					     $credential->extensions(),
					     $GeniUtil::EXTENSIONS_NS);
	    if ($nodes->size > 0) {
		$max_sliver_lifetime = int($nodes->pop()->string_value);
		last;
	    }
	}

	my $diff = $when - time();

	if ($diff < (60 * 5)) {
	    $message = "such a short life for a sliver? More time please.";
	    goto bad;
	}
	if ($diff > (3600 * 24 * $max_sliver_lifetime)) {
	    $message = "expiration is greater then the maximum number ".
		"(" . (60 * 24 * $max_sliver_lifetime) . ") of minutes";
	    goto bad;
	}
	if ($when > $slice_when) {
	    $message = "Expiration is greater then slice expiration";
	    goto bad;
	}
    }
    else {
	if (($slice_when - time()) > (3600 * 24 * $max_sliver_lifetime)) {
	    $message = "slice expiration is greater then the maximum number ".
		"(" . (60 * 24 * $max_sliver_lifetime) . ") of minutes";
	    goto bad;
	}
	$when = $slice_when;
    }
    if ($when < time()) {
	$message = "Expiration is in the past";
	goto bad;
    }
    
    if ($slice->SetExpiration($when) != 0) {
	$message = "Could not set expiration time";
	goto bad;
    }
    #
    # Need to delete any cached credentials.
    #
    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (defined($aggregate)) {
	GeniCredential->DeleteForTarget($aggregate);
    }
    $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 $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

    my $ticket = CheckTicket($tickstr);
    return $ticket
	if (GeniResponse::IsResponse($ticket));

    my $slice = GeniSlice->Lookup($credential->target_urn());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local slice found");
    }
    $ticket->SetSlice($slice);
    
    #
    # 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);
    }

    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));
    
    my $realuser = FlipToUser($slice, $user);
    if (! (defined($realuser) && $realuser)) {
	print STDERR "Error flipping to real user\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "FlipToUser Error");
    }
    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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

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

    my $sliver = GeniSliver->Lookup($credential->target_urn());
    if (!defined($sliver)) {
	# Might be an aggregate instead.
	$sliver = GeniAggregate->Lookup($credential->target_urn());
	if (!defined($sliver)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"No such sliver or aggregate");
	}
    }

    if (defined($manifest)) {
	$manifest = GeniXML::Parse($manifest);
	if (! defined($manifest)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Bad manifest");
	}
    }
    
    #
    # Lock the slice to avoid concurrent operation.
    #
    my $slice = $sliver->GetSlice();
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local slice found");
    }
    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));
    
    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 GeniXML::Serialize($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");
	}
    }
    my $realuser = FlipToUser($slice, $user);
    if (! (defined($realuser) && $realuser)) {
	print STDERR "Error flipping to real user\n";
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "FlipToUser Error");
    }
    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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    return DeleteSliverAux($credential, $impotent, 0);
}

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

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

    #
    # For now, only allow top level aggregate to be deleted.
    #
    my $aggregate = GeniAggregate->Lookup($credential->target_urn());
    if (!defined($aggregate)) {
	my $sliver = GeniSliver->Lookup($credential->target_urn());
	if (defined($sliver)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Must supply toplevel aggregate");
	}
	else {
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
					"No such sliver");
	}
    }
    elsif ($aggregate->type() ne "Aggregate") {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Must supply toplevel aggregate");
    }
    my $slice = $aggregate->GetSlice();
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));

    my $realuser = FlipToUser($slice, $user);
    if (! (defined($realuser) && $realuser)) {
	print STDERR "Error flipping to real user\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "FlipToUser Error");
    }
    my $slice_uuid = $slice->uuid();
    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }

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

    if (!$impotent) {
	system("$SNMPIT -C -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 (Firewall::undoFWNodes($experiment, 0) != 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;
	}

	my $output = GeniUtil::ExecQuiet("$SWAPEXP -g -o -q -s out $pid $eid");
	print STDERR $output;
	goto bad
	    if ($?);

	#
	# In the v2 API, caller returns a new ticket for the resources
	# (which were not released). 
	#
	if ($v2) {
	    # Slice still locked.
	    return 0;
	}
	$experiment->SetState(EXPTSTATE_SWAPPED());
	$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 $credstr = $argref->{'credential'};

    if (! defined($credstr)) {
	return GeniResponse->MalformedArgsResponse();
    }
    my $credential = CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($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. Might have been
    # expired out already.
    #
    my $slice = GeniSlice->Lookup($credential->target_urn());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No slice by that name");
    }
    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($)
{
    return GeniResponse->Create(GENIRESPONSE_UNSUPPORTED);
}

#
# 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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    return GetSliverAux($credential);
}

sub GetSliverAux($)
{
    my ($credential) = @_;
    
    $credential->HasPrivilege( "pi" ) or
	$credential->HasPrivilege( "info" ) or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );

    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));

    my $slice = GeniSlice->Lookup($credential->target_urn());
    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 $agg_credential = GeniCredential->Lookup($aggregate, $user);
    if (defined($agg_credential)) {
	#
	# Check for expiration and for changed certificate.
	#
	if ($agg_credential->IsExpired() ||
	    !$agg_credential->SameCerts($aggregate, $user)) {
	    $agg_credential->Delete();
	    $agg_credential = undef;
	}
    }
    if (!defined($agg_credential)) {
	$agg_credential = $aggregate->NewCredential($user);

	# Okay if this fails.
	$agg_credential->Store()
	    if (defined($agg_credential));
    }
    if (!defined($agg_credential)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				$agg_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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

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

    my $slice = GeniSlice->Lookup($credential->target_urn());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "Slice does not exist here");
    }
    
    #
    # Find or create the user.
    #
    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));

    if ($slice->Lock() != 0) {
	return GeniResponse->BusyResponse();
    }
    if (defined($keys)) {
	my $response = AddKeys($slice, $user, $keys);
	if (GeniResponse::IsResponse($response)) {
	    $slice->UnLock();
	    return $response;
	}
	$slice->MarkNodesForUpdate();
    }
    $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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    return ShutdownAux($credential, $clear);
}

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

    #
    # No slice here? Great. 
    #
    my $slice = GeniSlice->Lookup($credential->target_urn());
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED);
    }
    #
    # 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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    my $certificate = GeniRegistry::ClearingHouse->GetCertificate();
    if (!defined($certificate)) {
	print STDERR "Could not load ClearingHouse certificate\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

    # The caller (owner) has to match the clearinghouse.
    if (! ($credential->owner_urn() eq $certificate->urn() ||
	   $credential->target_urn() eq $certificate->urn())) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Only the clearinghouse can do this!");
    }
 
    $credential->HasPrivilege("listusage") or
	$credential->HasPrivilege("readhistory") or
	return GeniResponse->Create( GENIRESPONSE_FORBIDDEN, undef,
				     "Insufficient privilege" );
    
    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);
	}
	my $expires = POSIX::strftime("20%y-%m-%dT%H:%M:%SZ",
				      gmtime(str2time($slice->expires())));
	
	foreach my $sliver (@slivers) {
	    next
		if ($sliver->resource_type() ne "Node");

	    my $node = {"sliver_gid"    => $sliver->cert(),
			"sliver_hrn"    => $sliver->hrn(),
			"sliver_urn"    => $sliver->sliver_urn() };
	    
	    my $component = GeniComponent->Lookup($sliver->resource_uuid());
	    if (defined($component)) {
		$node->{"component_gid"} = $component->cert();
		$node->{"component_hrn"} = $component->hrn();
		$node->{"component_urn"} = $component->urn();
	    }
	    else {
		#
		# Do not warn about missing VMs. 
		#
		my $pnode = Node->Lookup($sliver->resource_id());
		if (!defined($pnode)) {
		    print STDERR "No node in DB for resource ".
			$sliver->resource_uuid() . "\n";
		}
		elsif (! $pnode->isvirtnode()) {
		    print STDERR "No component in DB for resource ".
			$sliver->resource_uuid() . ": $pnode\n";
		}
	    }
	    push(@components, $node);
	}
	next
	    if (!@components);
	
	my $blob = {"slice_gid"  => $slice->cert(),
		    "slice_hrn"  => $slice->hrn(),
		    "slice_urn"  => $slice->urn(),
		    "expires"    => $expires,
		    "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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    my $certificate = GeniRegistry::ClearingHouse->GetCertificate();
    if (!defined($certificate)) {
	print STDERR "Could not load clearinghouse certificate\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

    # The caller (owner) has to match the clearinghouse.
    if ($credential->owner_urn() ne $certificate->urn()) {
	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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

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

    my $slice = GeniSlice->Lookup($credential->target_urn());
    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_id   = $sliver->resource_id();
	my $node_uuid = $sliver->resource_uuid();
	my $node = GeniUtil::LookupNode($node_id);
	if (!defined($node)) {
	    $slice->UnLock();
	    print STDERR "Cannot find node $node_id\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	my $urn = GeniHRN::Generate($OURDOMAIN, "sliver", $node->node_id());

	if ($node->IsUp()) {
	    $details{$node_uuid} = "ready";
	    $detailsNew{$urn}    = "ready";
	}
	elsif ($node->eventstate() eq TBDB_NODESTATE_TBFAILED()) {
	    $details{$node_uuid} = "failed";
	    $detailsNew{$urn}    = "failed";
	    $summary = "failed";
	}
	else {
	    $details{$node_uuid} = "notready";
	    $detailsNew{$urn}    = "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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($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 = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));

    my $aggregate = GeniAggregate->Lookup($credential->target_urn());
    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 = $aggregate->GetSlice();
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice record for slice");
    }
    my $slice_uuid = $aggregate->slice_uuid();
    
    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 = GeniXML::Parse($row->{'manifest'});
    if (! defined($rspec)) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    #
    # Update the returned ticket to reflect the current expiration time.
    #
    GeniXML::SetExpires($rspec,
			POSIX::strftime("20%y-%m-%dT%H:%M:%SZ",
					gmtime(str2time($slice->expires()))));

    my $rspec_xml = GeniXML::Serialize($rspec);

    #
    # 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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($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($credential->target_urn());
    if (!defined($aggregate)) {
	my $sliver = GeniSliver->Lookup($credential->target_urn());
	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 = $aggregate->GetSlice();
    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_id   = $sliver->resource_id();
	my $node_uuid = $sliver->uuid();
	my $node = GeniUtil::LookupNode($node_id);
	if (!defined($node)) {
	    $slice->UnLock();
	    print STDERR "Cannot find node $node_id\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	my $urn = GeniHRN::Generate($OURDOMAIN, "sliver", $node->node_id());

	if ($node->IsUp()) {
	    $details{$node_uuid} = "ready";
	    $detailsNew{$urn}    = "ready";
	}
	elsif ($node->eventstate() eq TBDB_NODESTATE_TBFAILED()) {
	    $details{$node_uuid} = "failed";
	    $detailsNew{$urn}    = "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{$urn}    = "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 = CheckCredential($cred);
    return $credential
	if (GeniResponse::IsResponse($credential));

    my $user = CreateUserFromCertificate($credential);
    return $user
	if (GeniResponse::IsResponse($user));

    #
    # 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:%SZ",
			    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, $user) = @_;
    my $certificate = $credential->target_cert();

    # Should no longer happen, but lets make sure.
    if (!defined($certificate->urn()) &&
	GeniHRN::IsValid($certificate->urn())) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Malformed URN");
    }
    my $authority = CreateAuthorityFromCertificate($credential);
    return $authority
	if (GeniResponse::IsResponse($authority));

    #
    # The problem with URNs is that people will tend to reuse them.
    # So check to see if we have a slice with the same urn.
    #
    my $slice = GeniSlice->Lookup($certificate->urn());
    if (defined($slice)) {
	# Same certificate means it really is the same slice.
	return $slice
	    if ($certificate->SameCert($slice));

	# In the past we would destroy the old slice, but no longer
	# think this is the correct thing to do.
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Duplicate slice URN already exists here");
    }
    $slice = GeniSlice->Create($certificate, $user, $authority);
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Cannot create slice object")
	if (!defined($slice));

    #
    # The slice expires when the credential expires, or when the local policy
    # limit says, which ever is shorter. 
    #
    my $max_sliver_lifetime = 0;
    if (!GetSiteVar('protogeni/max_sliver_lifetime', \$max_sliver_lifetime)) {
	# Cannot get the value, default it to 90 days.
	$max_sliver_lifetime = 90;
    }
    my $expires = $credential->expires();
    # This is already a localtime.
    my $when = timelocal(strptime($expires));
    # Reverts to default in Create if this fails
    if (defined($when)) {
	my $diff = $when - time();

	if ($diff > (3600 * 24 * $max_sliver_lifetime)) {
	    # Shorten to policy maximum. Okay to use a unix time.
	    $expires = time() + (3600 * 24 * $max_sliver_lifetime);
	}
    }
    $slice->SetExpiration($expires);
    return $slice;
}

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

    #
    # We now force people to have URNs in their certs.
    #
    if (!defined($certificate->urn()) &&
	GeniHRN::IsValid($certificate->urn())) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Malformed URN");
    }
    my $urn = $certificate->urn();

    # Local users always exist, so pass flag.
    my $user = GeniUser->Lookup($certificate->urn(), 1);
    if (defined($user)) {
	#
	# See if the certificate changed. If it did, we have to update the
	# user record, but we want to use the old uuid since that is our
	# table cross reference index. Eventually uuid will no longer be
	# visible, but for now just keep on doing it.
	#
	return $user
	    if ($certificate->SameCert($user));

	#
	# Replace the user certificate. I think this is okay, since we
	# do not sign anything with the user key anyway. As long as we
	# keep the uuid from changing, all should be okay.
	#
	print STDERR "Updating certificate for $user to $certificate\n";
	$user->Flush();
	$certificate->Flush();
	$certificate->setuuid($user->uuid());
	$certificate->Store();
	$user = GeniUser->Lookup($certificate->urn());
	if (!defined($user)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Problem reloading your certificate");
	}
	return $user;
    }

    #
    # Check urn. Must be a "user" urn. The uid is checked in Create().
    #
    my (undef,$type,$uid) = GeniHRN::Parse($urn);
    if (!defined($uid) || $type ne "user") {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Malformed user URN");
    }
    my $authority = CreateAuthorityFromCertificate($credential);
    return $authority
	if (GeniResponse::IsResponse($authority));

    #
    # We want an email address to send expiration notifications to,
    # but PLC user certs do not have them. So, resolve the user at
    # the PLC to get it (and a proper name).
    #
    my $modify = 0;
    my $email  = $certificate->email();
    my $username;
    if (!defined($email) || $email eq "" || $email eq "unknown") {
	if (! defined($authority->url()) || !$authority->IsSFA()) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Your certificate does not include ".
					"an email address");
	}
	print STDERR "No email address in certificate for $urn\n";
	print STDERR "Trying to get email from $authority\n";

	my $registry = GeniRegistry::PLC->CreateFromAuthority($authority);
	if (!defined($registry)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not get registry at $authority ".
					"to get your email address");
	}

	my $blob = $registry->Resolve($urn);
	if (!defined($blob)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not resolve you at $registry ".
					"to get your email address");
	}
	# Why does PLC return an array?
	$blob  = $blob->[0];
	$email = $blob->{'email'};
	if (!defined($email) || $email eq "") {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Your authority record did ".
					"not include your email address");
	}
	# This is very PLC specific.
	$username = $blob->{'first_name'}
	    if (exists($blob->{'first_name'}));
	$username = ($username ? "$username " : "") . $blob->{'last_name'}
	    if (exists($blob->{'last_name'}));
	$modify = 1;
    }
    $user = GeniUser->Create($certificate, $authority);
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not create user from your certificate")
	if (!defined($user));

    if ($modify) {
	if ($user->Modify($username, $email)) {
	    $user->Delete();
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Could not update record ");
	}
    }
    return $user;
}

#
# When we have a credential, we can create the authority object using
# the signer certificate.
#
sub CreateAuthorityFromCertificate($)
{
    my ($credential) = @_;
    my $signers = $credential->signer_certs();
    my $certstr = @$signers[0];

    my $certificate = GeniCertificate->LoadFromString($certstr);
    if (!defined($certificate)) {
        print STDERR "Could not get certificate from $certstr\n";
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Could not load signer certificate");
    }
    if (! (defined($certificate->urn()) &&
	   GeniHRN::IsValid($certificate->urn()))) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Malformed URN in $certstr");
    }
    my $authority = GeniAuthority->Lookup($certificate->urn());
    if (defined($authority)) {
	# Same certificate means it really is the same authority
	return $authority
	    if ($certificate->SameCert($authority));

	#
	# Want to reuse the old uuid since we use it as a table cross
	# reference index. Eventually need to use the URN. Anyway, change
	# the uuid in the new certificate so that it goes into the DB
	# with the original one. Then update the Authority record with
	# the new certificate.
	#
	# XXX What about a URL change? 
	#
	print STDERR "Updating $authority with new certificate: $certificate\n";
	
	$certificate->setuuid($authority->uuid());
	if ($authority->UpdateCertificate($certificate)) {
	    print STDERR "Failed to update $authority with $certificate\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not update $authority certificate");
	}
	return $authority;
    }
    #
    # Check that this really is an SA.
    #
    my ($auth,$type,$id) = GeniHRN::Parse($certificate->urn());
    if (! ($type eq "authority" && $id eq "sa")) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			    "Signer certificate is not from a Slice Authority");
    }
    #
    # Protogeni signer certificates will have a URL in them. Otherwise it
    # is PLC or other framework and they must go through the AM interface.
    #
    my $url = $certificate->URL();
    if (!defined($url)) {
        print STDERR "$certificate does not have a URL extension\n";
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Signer certificate does not have a URL");
    }
    $authority = GeniAuthority->Create($certificate, $url, "sa");
    if (!defined($authority)) {
        print STDERR "unable to add authority from $certificate\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
		    "Could not create authority from $certificate");
    }
    return $authority;
}

#
# Create authority from the ClearingHouse, by looking up the info.
# We need this when we do not have a credential, wich at the moment
# is just one place.
#
sub CreateAuthorityFromRegistry($)
{
    my ($certificate) = @_;

    if (! (defined($certificate->urn()) &&
	   GeniHRN::IsValid($certificate->urn()))) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Malformed URN in certificate");
    }
    #
    # Transform whatever the urn is, to the corresponding SA urn.
    # Note that we will never find out if the slice authority has
    # changed its certificate. But we do not want to put in a call
    # to the authority from here, since it might block if it is
    # unreachable, and we do not want to block on this path. 
    #
    my ($auth,$type,$id) = GeniHRN::Parse($certificate->urn());
    my $sa_urn = GeniHRN::Generate($auth, "authority", "sa");
    my $authority = GeniAuthority->CreateFromRegistry("SA", $sa_urn);

    if (!defined($authority)) {
	print STDERR "Could not create authority for $sa_urn\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Could not create authority object for $sa_urn");
    }
    return $authority;
}

#
# Register/Unregister a local sliver at its slice authority.
#
sub RegisterSliver($)
{
    my ($slice) = @_;

    return RegisterAux($slice, 0);
}

sub UnRegisterSliver($)
{
    my ($slice) = @_;

    return RegisterAux($slice, 1);
}
sub RegisterAux($$)
{
    my ($slice, $unregister) = @_;
    my $credential;

    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (!defined($aggregate)) {
	print STDERR "Could not find aggregate for $slice\n";
	return -1;
    }
    my $authority = $slice->SliceAuthority();
    if (!defined($authority)) {
	print STDERR "Could not find authority for $slice\n";
	return -1;
    }
    if (!defined($authority->url()) || $authority->url() eq "") {
	print STDERR "No url for $authority; skipping registration\n";
	$aggregate->SetRegistered(1);
	return 0;
    }
    #
    # Ask for the version number to see how we need to do this.
    #
    my $version = $authority->Version();
    if (!defined($version)) {
	print STDERR "No version for $authority; skipping registration\n";
	return 0;
    }
    if ($version == 1) {
	#
	# Old API; uses a bogus self signed credential.
	#
	my $context = Genixmlrpc->GetContext();
	$credential = GeniCredential->CreateSigned($authority,
						   $context->certificate(),
						   $context->certificate());
    }
    else {
	my $me = GeniAuthority->Lookup($ENV{'MYURN'});
	
	if (!defined($me)) {
	    # This should be done in initsite.
	    system("$ADDAUTHORITY -a $EMULAB_PEMFILE cm");
	}
	$me = GeniAuthority->Lookup($ENV{'MYURN'});
	if (!defined($me)) {
	    print STDERR
		"Could not find local authority object for $ENV{'MYURN'}\n";
	    return -1;
	}
	$credential = $aggregate->NewCredential($me);
    }
    if (!defined($credential)) {
	print STDERR "Could not create a credential for $authority\n";
	return -1;
    }
    my $registry = GeniRegistry::Client->Create($authority,undef,$credential);
    if (!defined($registry)) {
	print STDERR "Could not create a registry client for $authority\n";
	return -1;
    }
    
    if ($unregister) {
	$registry->UnRegisterSliver($slice->urn());
    }
    else {
	my $creator = $aggregate->GetCreator();
	if (!defined($creator)) {
	    print STDERR "Could not find creator for $slice\n";
	    return -1;
	}
	my $blob = {
	    "urn"           => $aggregate->urn(),
	    "creator_urn"   => $creator->urn(),
	    "created"       => $slice->created(),
	    "expires"       => $slice->expires(),
	    "manifest"      => $aggregate->GetManifest(1),
	};

	if ($registry->RegisterSliver($slice->urn(), $blob) == 0) {
	    $aggregate->SetRegistered(1);
	}
    }
    return 0;
}

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

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

    if (!defined(FlipToUser($slice))) {
	print STDERR "CleanupDeadSlice: Could not flip to user\n";
	return -1;
    }

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

	#
	# Clear ports from shared vlans.
	#
	if ($experiment->ClearPortLans()) {
	    print STDERR "Could not clear portvlans\n";
	    return -1;
	}
	
	system("$SNMPIT -C -r $pid $eid");
	if ($?) {
	    print STDERR "Could not tear down vlans\n";
	    return -1;
	}

	#
	# Remove any stale vlans.
	#
	my @stale;
	if (VLan->StaleVlanList($experiment, \@stale) != 0) {
	    print STDERR "Failed to get stale VLANs\n";
	    return -1;
	}
	if (@stale) {
	    print STDERR "Removing stale vlans @stale\n";
	    system("$SNMPIT -f ". join(" ", map("-o $_", @stale)));
	    if ($?) {
		print STDERR "Failed to remove stale VLANs\n";
		return -1;
	    }
	}

	#
	# A firewalled slice gets special treatment.
	#
	if ($slice->needsfirewall()) {
	    print STDERR "Calling undoFWNodes ...\n";
	    
	    if (Firewall::undoFWNodes($experiment, 0) != 0) {
		print STDERR "FireWall cleanup failed\n";
		return -1;
	    }
	}
    }
    my $topaggregate = GeniAggregate->SliceAggregate($slice);
    if (defined($topaggregate) && $topaggregate->registered()) {
	# Unregister the slice at the SA.
	UnRegisterSliver($slice);
    }
    GeniCredential->DeleteForTarget($topaggregate)
	if (defined($topaggregate));

    #
    # 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)) {
	# Do this so that a full swapout is done. Better then trying
	# to guess what parts to do here. 
	$experiment->SetState(EXPTSTATE_ACTIVE());
	
	my $pid = $experiment->pid();
	my $eid = $experiment->eid();

	#
	# Lets wait for this to complete so that we do not terminate
	# the slice if there is an error. Sure, it means the client
	# waits longer. 
	#
	my $output;
	if ($purge) {
	    $output = GeniUtil::ExecQuiet("$ENDEXP -g -o -q $pid,$eid");
	}
	else {
	    $output = GeniUtil::ExecQuiet("$SWAPEXP -g -o -q -s out $pid $eid");
	}
	print STDERR $output;
	return -1
	    if ($?);
	
	if ($purge) {
	    $experiment->Flush();
	    $slice->SetExperiment(undef);
	}
    }
    return 0
	if (!$purge);
    
    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, $creator) = @_;

    my $uuid = $slice->uuid();
    my $urn  = $slice->urn();
    my ($pid, $gid, $eid);
    my ($project, $group);

    my $experiment = Experiment->Lookup($uuid);
    return $experiment
	if (defined($experiment));

    # The eid is derived from the slice urn.
    (undef, undef, $eid) = GeniHRN::Parse($urn);

    require Project;
    require Group;
    
    #
    # If the slice is from this Emulab (SA), then we are going to create the
    # experiment in the local project.
    #
    if (GeniHRN::Authoritative($urn, $OURDOMAIN) && $USELOCALPROJ) {
	#
	# If no creator, this is a placeholder slice. Since its local
	# we can come up with a creator, but later.
	#
	if (!defined($creator)) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				"Cannot do local placeholder slices yet");
	}
	
	#
	# For now, the creator has to be a local user and have their
	# default project set. Until we have project signed credentials.
	#
	if (! $creator->IsLocal()) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			"$creator is not a local user for local project");
	}
	if (!defined($creator->DefaultProject())) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"No default project for $creator");
	}
	$project = $creator->DefaultProject();
	if (!defined($project)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not get local project for $slice");
	}
	# No sub groups for local projects. Maybe later?
	$pid = $gid = $project->pid();
    }
    else {
	#
	# The top level domain of the SA becomes the project name, but the
	# dots are illegal of course, and there might be sub authorities
	# (colon separated). We use the primary for the project and the
	# first sub-authority for the group.
	#
	my ($domain, undef, undef) = GeniHRN::Parse($urn);
	my @tokens = split(":", $domain);
	my $project_id = shift(@tokens);
	my $group_id = shift(@tokens) if (@tokens);
	my $project_urn = GeniHRN::Generate($project_id, "authority", "sa");
	
	#
	# See if the project exists. 
	#
	$project = Project->LookupNonLocal($project_urn);
	if (!defined($project)) {
	    #
	    # For now, lets assume that the domain has legal chars, except
	    # of course for the dots, which we transform to dashes cause
	    # underscores are not allowed in project ids.
	    #
	    $project_id =~ s/\./-/g;	    
	    if (!Project->ValidPID($project_id)) {
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
		    "Cannot form a valid local project name from $project_urn");
	    }

	    #
	    # Write out a little XML file describing the project, and
	    # let the existing backend script deal with it all.
	    #
	    my ($fh, $filename) = tempfile(UNLINK => 0);
	    if (!defined($fh)) {
		print STDERR "Could not create temp file for $project_id\n";
		return GeniResponse->Create(GENIRESPONSE_ERROR);
	    }
	    print $fh "<project>\n";
	    print $fh " <attribute name=\"name\">\n";
	    print $fh "  <value>$project_id</value>\n";
	    print $fh " </attribute>\n";
	    print $fh " <attribute name=\"short description\">\n";
	    print $fh "  <value>$project_urn</value>\n";
	    print $fh " </attribute>\n";
	    print $fh " <attribute name=\"nonlocal_id\">\n";
	    print $fh "  <value>$project_urn</value>\n";
	    print $fh " </attribute>\n";
	    print $fh " <attribute name=\"nonlocal_type\">\n";
	    print $fh "  <value>protogeni</value>\n";
	    print $fh " </attribute>\n";
	    print $fh " <attribute name=\"leader\">\n";
	    print $fh "  <value>geniuser</value>\n";
	    print $fh " </attribute>\n";
	    print $fh "</project>\n";
	    close($fh);
	    if (! chmod(0755, $filename)) {
		print STDERR "Could not chmod $filename\n";
		return GeniResponse->Create(GENIRESPONSE_ERROR);
	    }
	    #
	    # This operation has to be done as an admin person. 
	    #
	    GeniUtil::FlipToElabMan();
	    my $output = GeniUtil::ExecQuiet("$WAP $NEWPROJECT -l $filename");
	    if ($?) {
		GeniUtil::FlipToGeniUser();
		print STDERR $output;
		return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Internal error creating project description");
	    }
	    unlink($filename);

	    $output = GeniUtil::ExecQuiet("$WAP $MAKEPROJECT $project_id");
	    my $ecode  = $?;
	    GeniUtil::FlipToGeniUser();
	    if ($ecode) {
		print STDERR $output;
		return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					    "Internal error creating project");
	    }
	    $project = Project->LookupNonLocal($project_urn);
	    if (!defined($project)) {
		print STDERR "Cannot lookup new project for $project_id\n";
		return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Internal error locating project after creation");
	    }
	}
	$pid = $gid = $project->pid();
	
	#
	# If there is a sub authority, create a subgroup for it.
	#
	if (defined($group_id)) {
	    if (!Group->ValidGID($group_id)) {
		return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Invalid  local group name $group_id");
	    }
	    $group = $project->LookupGroup($group_id);

	    if (!defined($group)) {
		my $pid_idx = $project->pid_idx();
		
		#
		# Write out a little XML file describing the group, and
		# let the existing backend script deal with it all.
		#
		my ($fh, $filename) = tempfile(UNLINK => 0);
		if (!defined($fh)) {
		    print STDERR "Could not create temp file for group $group_id\n";
		    return GeniResponse->Create(GENIRESPONSE_ERROR);
		}
		print $fh "<group>\n";
		print $fh " <attribute name=\"project\">\n";
		print $fh "  <value>$pid_idx</value>\n";
		print $fh " </attribute>\n";
		print $fh " <attribute name=\"group_id\">\n";
		print $fh "  <value>$group_id</value>\n";
		print $fh " </attribute>\n";
		print $fh " <attribute name=\"group_leader\">\n";
		print $fh "  <value>geniuser</value>\n";
		print $fh " </attribute>\n";
		print $fh " <attribute name=\"group_description\">\n";
		print $fh "  <value></value>\n";
		print $fh " </attribute>\n";
		print $fh "</group>\n";
		close($fh);
		my $output = GeniUtil::ExecQuiet("$NEWGROUP $filename");
		if ($?) {
		    print STDERR $output;
		    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					    "Internal error creating group");
		}
		unlink($filename);

		$group = $project->LookupGroup($group_id);
		if (!defined($group)) {
		    print STDERR "Cannot lookup new group for $group_id\n";
		    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			"Internal error locating group after creation");
		}
	    }
	    $gid = $group->gid();
	}
    }

    #
    # Form an eid for the experiment. 
    #
    if (! Experiment->ValidEID($eid)) {
	# What shall we do?
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "$eid is not a valid experiment ID");
    }

    #
    # If the creator is a local user, and the project is a local project,
    # then the experiment is created as that user, since geniuser is not
    # a member. That means we have to run as the local user.
    #
    if ($project->IsLocal()) {
	$creator->FlipTo($project->unix_gid());
    }
    elsif (defined($group)) {
	GeniUtil::FlipToGeniUser($group->unix_gid());
    }
    else {
	GeniUtil::FlipToGeniUser($project->unix_gid());
    }

    # Note the -h option; allows experiment with no NS file.
    system("$CREATEEXPT -N -q -i -k -w ".
	   "-S 'Geni Slice Experiment -- DO NOT SWAP OR TERMINATE' ".
	   "-E '$urn' ".
	   "-L 'Geni Slice Experiment -- DO NOT SWAP OR TERMINATE' ".
	   "-h '$uuid' -p $pid -g $gid -e $eid");
    my $saved_exitcode = $?;

    # Flip back to geni user. Will reset later.
    GeniUtil::FlipToGeniUser();

    if ($saved_exitcode) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Error creating container experiment");
    }
    $experiment = Experiment->Lookup($uuid);
    $experiment->SetState(EXPTSTATE_SWAPPED());
    $experiment->Update({"geniflags"  => $Experiment::EXPT_GENIFLAGS_EXPT});
    $experiment->TableUpdate("experiment_stats",
			     "geniflags='$Experiment::EXPT_GENIFLAGS_EXPT', ".
			     "slice_uuid='$uuid'");
    # XXX watch for "placeholder" slices. 
    $experiment->MarkNonlocal($urn,
			      (defined($creator) ? $creator->urn() : undef),
			      "protogeni");
    $slice->SetExperiment($experiment);
    return $experiment;
}

#
# Given slice and user, flip to the proper user to operate as.
#
sub FlipToUser($$)
{
    my ($slice, $user) = @_;
    my $debug = 1;

    my $experiment = $slice->GetExperiment();
    # No experiment, no reason to flip.
    return 0
	if (!defined($experiment));
    my $project = $experiment->GetProject();
    return undef
	if (!defined($project));

    #
    # Nonlocal projects, operate as geniuser with added gid.
    # XXX watch for Legacy GeniSlices project.
    #
    if ($project->IsNonLocal() || $project->pid() eq "GeniSlices") {
	require User;
	
	my $group = $experiment->GetGroup();
	return undef
	    if (!defined($group));

	my $geniuser = User->Lookup("geniuser");
	return undef
	    if (!defined($geniuser));
	$geniuser = GeniUser::LocalUser->Create($geniuser);

	print STDERR "FlipToUser: $geniuser, $group\n"
	    if ($debug);
	
	return undef
	    if ($geniuser->FlipTo($group->unix_gid()));
	return $geniuser;
    }

    #
    # Local project. If no user or if the user is nonlocal, then we need
    # to operate as the slice (well, experiment) creator, since
    # geniuser has no permissions in (not a member of) the project.
    #
    if (!defined($user) || !$user->IsLocal()) {
      usecreator:
	$user = $experiment->GetCreator();
	return undef
	    if (!defined($user));

	# No subgroups yet.
	print STDERR "FlipToUser: $user, $project\n"
	    if ($debug);
	return undef
	    if ($user->FlipTo($project->unix_gid()));

	return $user;
    }
    
    #
    # Local user, local project. Is the user a member of the project?
    # If not, then like above we have to operate as the experiment
    # creator since the user has no privs in the project. Generally,
    # this will happen if a credential is delegated (rare) or if the
    # creator binds a user to a slice. 
    #
    goto usecreator
	if (!$experiment->AccessCheck($user->emulab_user(),
				      $Experiment::EXPT_ACCESS_MODIFY));

    print STDERR "FlipToUser: $user, $project\n"
	if ($debug);
    
    return undef
	if ($user->FlipTo($project->unix_gid()));
    return $user;
}

#
# Update the manifest with the new vlan tags. 
#
sub UpdateManifest($)
{
    my ($slice) = @_;
    require Lan;

    my $experiment = Experiment->Lookup($slice->uuid());
    if (!defined($experiment)) {
	print STDERR "No local experiment for $slice\n";
	return -1;
    }
    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (!defined($aggregate)) {
	print STDERR "No aggregate for $slice\n";
	return -1;
    }
    my $rspec = $aggregate->GetManifest(0);
    if (!defined($rspec)) {
	print STDERR "No manifest for $slice/$aggregate\n";
	return -1;
    }
    my @vlanlist = ();
    my %vlantags = ();
    VLan->ExperimentVLans($experiment, \@vlanlist);
    foreach my $vlan (@vlanlist) {
	my $tag;
	$vlan->GetTag(\$tag);
	if (!defined($tag)) {
	    print STDERR "UpdateManifest: No tag for $vlan\n";
	}
	$vlantags{$vlan->vname()} = $tag;

	#
	# Encapsulation vlan, so need to find the actual link name.
	#
	my $linklan;

	if ($vlan->GetAttribute("link/lan", \$linklan) == 0 &&
	    defined($linklan)) {
	    $vlantags{$linklan} = $tag;
	}
    }
    foreach my $linkref (GeniXML::FindNodes("n:link", $rspec)->get_nodelist()){
	my $vname = GeniXML::GetVirtualId($linkref);
	my $tag = undef;
	if (defined($vname) && exists($vlantags{$vname})) {
	    $tag = $vlantags{$vname};
	}
	if (!defined($tag)) {
	    GeniXML::RemoveChild("vlantag", $linkref);
	}
	else {
	    GeniXML::SetText("vlantag", $linkref, $tag);
	}
	
    }
    my $manifest = GeniXML::Serialize($rspec);
    
    #
    # Move this elsewhere.
    #
    $manifest = DBQuoteSpecial($manifest);
    my $slice_uuid = $slice->uuid();

    DBQueryWarn("update geni_manifests set ".
		"  manifest=$manifest ". 
		"where slice_uuid='$slice_uuid'");

    return 0;
}

sub CheckCredential($)
{
    my $credential = GeniCredential->CreateFromSigned($_[0]);
    if (!defined($credential)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    $GeniCredential::CreateFromSignedError);
    }

    #
    # Well formed credentials must now have URNs.
    #
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Malformed credentials; missing URNs")
	if (! (defined($credential->owner_urn()) &&
	       defined($credential->target_urn()) &&
	       GeniHRN::IsValid($credential->owner_urn()) &&
	       GeniHRN::IsValid($credential->target_urn())));
	
    #
    # Make sure the credential was issued to the caller.
    #
    if ($credential->owner_urn() ne $ENV{'GENIURN'}) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "This is not your credential");
    }
    return $credential;
}

sub CheckTicket($)
{
    my $ticket = GeniTicket->CreateFromSignedTicket($_[0]);
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    $GeniTicket::CreateFromSignedError);
    }
    #
    # Well formed tickets must now have URNs.
    #
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Malformed credentials; missing URNs")
	if (! (defined($ticket->owner_urn()) &&
	       defined($ticket->target_urn()) &&
	       GeniHRN::IsValid($ticket->owner_urn()) &&
	       GeniHRN::IsValid($ticket->target_urn())));
	
    #
    # Make sure the ticket was issued to the caller.
    #
    if ($ticket->owner_urn() ne $ENV{'GENIURN'}) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "This is not your ticket");
    }

    #
    # Make sure the ticket target is this Manager
    #
    if ($ticket->target_urn() ne $ENV{'MYURN'}) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "This ticket is for another CM!");
    }
    
    return $ticket;
}

sub AddKeys($$$)
{
    my ($slice, $owner, $keys) = @_;

    goto bad
	if (! (ref($keys) && ref($keys) eq "ARRAY"));

    my $slice_experiment = $slice->GetExperiment();
    if (!$slice_experiment) {
	print STDERR "AddKeys: No experiment for $slice\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }

    my $keychecker = sub {
	my ($arg) = @_;

	return -1
	    if (! (ref($arg) && ref($arg) eq "HASH"));

	my $key  = $arg->{'key'};
	my $type = $arg->{'type'};

	return -1
	    if (! (defined($arg) && defined($arg) &&
		   $key ne "" && $type ne ""));
	
	return 0;
    };

    #
    # The old format (which we still want to support) was
    # a single list of keys for the user redeeming a ticket.
    #
    # The new format is a list of users, each with sshkeys. 
    # The hash key is the urn of the user. 
    #
    if (exists($keys->[0]->{'urn'}) || exists($keys->[0]->{'login'})) {
	foreach my $ref (@{ $keys }) {
	    goto bad
		if (! (exists($ref->{'urn'}) || exists($ref->{'login'})));

	    my @keylist = ();
	    
	    foreach my $keyref (@{ $ref->{'keys'} }) {
		goto bad
		    if (&$keychecker($keyref) != 0);

		push(@keylist, $keyref->{'key'});
	    }
	    my $urn;
	    my $uid;
	    my $name;
	    my $email;

	    $urn = $ref->{'urn'} if (exists($ref->{'urn'}));
	    # Allow user to override urn token.
	    $uid = $ref->{'login'} if (exists($ref->{'login'}));
	    
	    # The slice owner is easy.
	    if (defined($urn) && $urn eq $owner->urn()) {
		$name  = $owner->name();
		$email = $owner->email();
		$uid   = $owner->uid()
		    if (!defined($uid));
	    }
	    else {
		#
		# Trickier, since we have no email and no name, and
		# we might have to derive the login uid from the urn, which
		# might not even be a valid uid for Emulab. 
		#
		if (!defined($uid)) {
		    my (undef,$type,$id) = GeniHRN::Parse($urn);
		    if (!defined($id) || $type ne "user") {
			goto bad;
		    }
		    $uid = $id;
		}
		$name = $uid;
		$email = "root\@localhost";
	    }
	    if (! GeniUser->ValidUserID($uid)) {
		my $digest = sha1_hex($uid);
		$digest = substr($digest, 0, 7);
		$uid = lc("u${digest}");
		if (GeniUser->ValidUserID($uid)) {
		    print STDERR "Cannot form a uid for $name\n";
		    goto bad;
		}
	    }
	    $slice_experiment->BindNonLocalUser(\@keylist,
						$uid, $urn,
						$name, $email)
		== 0 or goto error;
	}
    }
    else {
	my @keylist = ();
	
	foreach my $keyref (@{ $keys }) {
	    goto bad
		if (&$keychecker($keyref) != 0);

	    push(@keylist, $keyref->{'key'});
	}
	$slice_experiment->BindNonLocalUser(\@keylist,
					    $owner->uid(),
					    $owner->urn(),
					    $owner->name(),
					    $owner->email()) == 0
	    or goto error;
    }
    return 0;
  bad:
    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef, "Malformed keys");
  error:
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef, "Internal Error");
}

sub GetHopLinkID($)
{
    my ($ref)  = @_;
    my $result = "";
			
    my $link = FindFirst("n:link", $ref);
    if (defined($link)) {
	$result = GetText("id", $link);
    }
    return $result;
}

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