#!/usr/bin/perl -wT
#
# Copyright (c) 2008-2015 University of Utah and the Flux Group.
# 
# {{{GENIPUBLIC-LICENSE
# 
# GENI Public License
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and/or hardware specification (the "Work") to
# deal in the Work without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Work, and to permit persons to whom the Work
# is furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Work.
# 
# THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE WORK OR THE USE OR OTHER DEALINGS
# IN THE WORK.
# 
# }}}
#
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    = qw(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 GeniStitch;
use GeniUsage;
use GeniImage;
use libtestbed;
use emutil;
use EmulabConstants;
use libEmulab;
use Lan;
use User;
use Experiment;
use NodeType;
use Node;
use English;
use Data::Dumper;
use XML::Simple;
use XML::LibXML;
use Date::Parse;
use POSIX qw(strftime tmpnam ceil);
use Time::Local;
use Compress::Zlib;
use File::Temp qw(tempfile);
use MIME::Base64;
use Digest::SHA1 qw(sha1_hex);
use POSIX ":sys_wait_h";

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $TBBASE         = "@TBBASE@";
my $TBDOCBASE      = "@TBDOCBASE@";
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 $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 $IMAGE_SETUP    = "$TB/sbin/image_setup";
my $IMAGE_IMPORT   = "$TB/sbin/image_import";
my $SHAREVLAN      = "$TB/sbin/sharevlan";
my $FWNAME	   = "fw";
my $API_VERSION    = 1;
my $PROTOGENI_LOCALUSER   = @PROTOGENI_LOCALUSER@;
my $PROTOGENI_NONFSMOUNTS = @PROTOGENI_NONFSMOUNTS@;

# For location info.
my $default_longitude = undef;
my $default_latitude  = undef;
my $default_country   = undef;

#
# 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 = GeniCredential::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 = GeniCredential::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 -f";
    if (defined($experiment)) {
	my $eid = $experiment->eid();
	my $pid = $experiment->pid();
	$invocation .= " -p $pid -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 = GeniCredential::CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

    if ($isupdate) {
	$ticket = CheckTicket($tickstr, $credential->target_urn());
	return $ticket
	    if (GeniResponse::IsResponse($ticket));
    }
    return GetTicketAux($credential,
			$rspecstr, $isupdate, $impotent, 0, 1, 0, $ticket);
}

sub GetTicketAux($$$$$$$$$@)
{
    my ($credential, $rspecstr, $isupdate, $impotent, $v2, $level, $usetracker,
	$ticket, $speaksfor, @morecreds) = @_;
    
    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));
    }
    $slice->SetSpeaksFor($speaksfor)
	if (defined($speaksfor));
	
    main::AddLogfileMetaDataFromSlice($slice);
    
    return GetTicketAuxAux($slice, $user, $rspecstr,
			   $isupdate, $impotent, $v2, $level, $usetracker,
			   $ticket, [$credential, @morecreds], $speaksfor);
}
sub GetTicketAuxAux($$$$$$$$$$$)
{
    my ($slice, $user, $rspecstr, $isupdate,
	$impotent, $v2, $level, $usetracker,
	$ticket, $credentials, $speaksfor) = @_;
    my $response    = undef;
    my $restorevirt = 0;	# Flag to restore virtual state
    my $restorephys = 0;	# Flag to restore physical state
    require OSinfo;
    require Image;
    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;
    }

    # Image tracker.
    my $use_imagetracker;
    if (!GetSiteVar('protogeni/use_imagetracker', \$use_imagetracker)) {
	# Cannot get the value, say no.
	$use_imagetracker = 0;
    }
    # But the Portal is currently the one telling us to use the tracker
    # for specific slices.
    $use_imagetracker = 1
	if ($use_imagetracker && $usetracker);

    # 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 (GeniResponse::IsResponse($expires)) {
	    return $expires;
	}
	# Note "checkonly" flag; we do not actually change the slice
	# until the ticket is redeemed. 
	my $tmp = SetSliceExpiration($slice, $expires, 1, 0, @{ $credentials });
	if (GeniResponse::IsResponse($tmp)) {
	    return $tmp;
	}
    }

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

    #
    # Look for toplevel address pools
    #
    if (Node::HaveExperimentNodes()) {
	my $address_pools = GeniXML::GetAddressPools($rspec);
	foreach my $pool (@{ $address_pools }) {
	    if (! defined($pool->{'cmurn'}) ||
		$pool->{'cmurn'} eq $ENV{'MYURN'})
	    {
		if ($pool->{'type'} ne "any") {
		    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
		     "Only public address pools of type any are supported");
		    goto bad;
		}
		print STDERR 'DEBUG: Adding row to virt_address_allocation';
		$virtexperiment->NewTableRow("virt_address_allocation",
					 {"pool_id" => $pool->{'client_id'},
					  "count" => $pool->{'count'},
					  "restriction" => $pool->{'type'},
					  "version" => "ipv4" });
	    }
	}
    }

    #
    # Look for toplevel elabinelab section.
    #
    my $elabinelab_settings = GeniXML::GetElabInElabSettings($rspec);
    if (defined($elabinelab_settings)) {
	$virtexperiment->elab_in_elab(1);
	if (exists($elabinelab_settings->{'singlenet'})) {
	    $virtexperiment->elabinelab_singlenet(1);
	}
	if (exists($elabinelab_settings->{'xen'})) {
	    $virtexperiment->multiplex_factor(2);
	}
    }
    if ($PROTOGENI_NONFSMOUNTS) {
	$virtexperiment->nonfsmounts(1);
    }

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

    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();
    
    #
    # 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) {
	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;
	my $xensettings;
	my $fwsettings;
	
	if (exists($nodeexistsmap{lc($node_nickname)})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate node $node_nickname");
	    goto bad;
	}
	$nodeexistsmap{lc($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 total hostname length > 63 characters. This
	# breaks a lot of clients. Do this until we have a plan
	# for dealing with it on the clients. Why 63 instead of 64?
	# Cause of a bug in the event library code, that is now fixed,
	# but will not make it out to all images for a while. 
	#
	my $fullhostname = $node_nickname . ".${eid}.${pid}.${OURDOMAIN}";
	if (0 && length($fullhostname) > 63) {
	    $response = GeniResponse->Create(GENIRESPONSE_TOOBIG, undef,
				     "Hostname > 63 characters: $fullhostname");
	    goto bad;
	}
	#
	# Check for disk_image request. Specified as a URN. 
	#
	my $diskref = GeniXML::GetDiskImage($ref);
	if (defined($diskref)) {
	    my $dname = GeniXML::GetText("name", $diskref);
	    my $url   = GeniXML::GetText("url", $diskref);

	    # url is deprecated; name can be anything.
	    if (defined($dname) && $dname =~ /^http/) {
		$url = $dname;
	    }

	    if (defined($url)) {
		if (! TBcheck_dbslot($url, "virt_nodes", "osname",
				 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)){
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid disk image url: $url");
		    goto bad;
		}
		#
		# Pass it right through; we load them later.
		# There is no osinfo, but see below. 
		#
		$osname = $url;
	    }
	    elsif (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,undef,$vers) =
		    ($id =~ m{([^/]+)//([^/]+)(//(\d+))?});		
		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, $vers);
		if (!defined($osinfo)) {
		    if ($use_imagetracker) {
			my $image = GeniImage::MapToLocalImage($dname, $pid);
			if (GeniResponse::IsError($image)) {
			    $response = $image;
			    goto bad;
			}
			$osname = ($image->IsLocal() ?
				   $image->versname() :
				   $image->metadata_url());
		    }
		    else {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Unknown image URN: $dname");
			goto bad;
		    }
		}
		else {
		    #
		    # 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";
		    $osname .= ":${vers}" if (defined($vers));
		}
	    }
	}

	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";
			    }
			}
			elsif (!defined($osname)) {
			    # Allow for url above.
			    $osname = "OPENVZ-STD";
			}
		    }
		    elsif ($virtualization_subtype eq "emulab-xen" ||
			   $virtualization_subtype eq "default-vm") {
			# 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 = "UBUNTU12-64-STD";
			    }
			}
			elsif (!defined($osname)) {
			    # Allow for url above.
			    $osname = "UBUNTU12-64-STD";
			}
			#
			# Look for the knobs
			#
			if (GeniXML::HasXenSettings($ref)) {
			    $xensettings = GeniXML::GetXenSettings($ref);
			}
			my $ptype = GeniXML::XenPtype($ref);
			$pctype = $ptype
			    if (defined($ptype));
			$virtexperiment->encap_style("vlan");

			#
			# Per-vnode firewall options.
			#
			if (GeniXML::HasFirewallSettings($ref)) {
			    $fwsettings = GeniXML::GetFirewallSettings($ref);
			}
		    }
		    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 "emulab-blockstore") {
			$osname = "BLOCKSTORE-VM";
			$pctype = "blockstore";
		    }
		    elsif ($virtualization_subtype eq "emulab-connect") {
			$osname = "GENERICDEV-VM";
			$pctype = "interconnect-vm";
			# Lets force to shared node.
			GeniXML::SetExclusive($ref, 0);
			$exclusive = 0;
			# Kludge for libvtop.
			$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};
	    }
	    #
	    # Watch for pcvm type set above. If the user specified
	    # a hardware type for their VMs, then form a proper
	    # hardware specific pcvm type.
	    #
	    if (defined($pctype) && $pctype eq "pcvm" &&
		(my $usertype =
		 GeniXML::FindFirst("n:hardware_type", $ref))) {
		my $htype = GeniXML::GetText("name", $usertype);
		if (defined($htype)) {
		    $pctype = "${htype}-vm";
		}
	    }
	    $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: " . TBFieldErrorString());
		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: " . TBFieldErrorString());
		    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 (!defined($service->{'cmd'}) ||
			$service->{'cmd'} eq "") {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			     "Invalid service command: no command provided");
			goto bad;
		    }
		    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: " . TBFieldErrorString());
		    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 $elabsettings = GeniXML::GetElabInElabSettings($ref);
	if (defined($elabsettings)) {
	    my $extradisksize;
	    my $extradiskmnts;
	    
	    if (exists($elabsettings->{'role'})) {
		my $erole = $elabsettings->{'role'};
		my $role;
		
		$nodeblob->{'inner_elab_role'} = $erole;

		if ($erole =~ /boss/) {
		    $extradisksize = "disk1:10G,disk2:10G,disk3:10G";
		    $extradiskmnts =
			"da1:/usr/testbed,da2:/usr/testbed/data,da3:".
			"/usr/testbed/log";
		    $role = "boss";
		}
		else {
		    $extradisksize = "disk1:4G,disk2:10G,disk3:10G";
		    $extradiskmnts =
			"da1:/usr/testbed,da2:/q,da3:/share";
		    $role = "ops";
		}
		$virtexperiment->NewTableRow("virt_node_attributes",
					     {"vname"     => $node_nickname,
					      "attrkey"   => "XEN_EXTRADISKS",
					      "attrvalue" => $extradisksize});
		$virtexperiment->NewTableRow("elabinelab_attributes",
					     {"role"      => $role,
					      "attrkey"   => "EXTRADISKS",
					      "attrvalue" => $extradiskmnts,
					      "ordering"  => 0});
	    }
	    else {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "No role for elabinelab");
		goto bad;
	    }
	}

	# Failure action.
	my ($failure_ref) =
	    GeniXML::FindNodesNS("n:failure_action",
				 $ref,
				 $GeniXML::EMULAB_NS)->get_nodelist();
	if (defined($failure_ref)) {
	    my $action = GeniXML::GetText("action", $failure_ref);
	    if ($action ne "nonfatal") {
		$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
						 "Bad failure action");
		goto bad;
	    }
	    $nodeblob->{'failureaction'} = $action;
	}

	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);
	
	$virtexperiment->NewTableRow("virt_node_desires",
				     {"vname"    => $node_nickname,
				      "desire"   => "d820-explicit",
				      "weight"   => 0.95})
	    if ($MAINSITE && !defined($exclusive) || !$exclusive);

	#
	# Special hack for allocating from a specific chassis.
	#
	my ($chassis) =
	    GeniXML::FindNodesNS("n:moonshot_chassis", $ref,
				 $GeniXML::EMULAB_NS)->get_nodelist();
	if (defined($chassis)) {
	    my $chnum = GetText("chassis", $chassis);
	    if ($chnum !~ /^\d+$/ || $chnum < 0 || $chnum > 8) {
		$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad chassis number");
		goto bad;
	    }
	    $virtexperiment->NewTableRow("virt_node_desires",
					 {"vname"    => $node_nickname,
					  "desire"   => "ms-chassis${chnum}",
					  "weight"   => 1.0})
	}

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

	if (defined($xensettings)) {
	    foreach my $setting (keys(%$xensettings)) {
		my $attrvalue = $xensettings->{$setting};
		my $attrkey;
		my $isshared  = (!defined($exclusive) || !$exclusive ? 1 : 0);

		if ($attrvalue !~ /^\d*$/) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Bad XEN setting; integers only");
		    goto bad;
		}
		if ($setting eq "ram") {
		    if ($attrvalue < 128) {
			# ignore silly user.
			next;
		    }
		    if ($isshared && 0 && $attrvalue > 1024) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad XEN setting; ".
						 "limited to 1024 MB");
			goto bad;
		    }
		    $attrkey = "XEN_MEMSIZE";
		}
		elsif ($setting eq "cores") {
		    $attrkey = "XEN_CORES";
		    if ($attrvalue <= 0) {
			# ignore silly user.
			next;
		    }
		    if ($isshared && $attrvalue > 4) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad XEN setting; ".
						 "limited to 1-4 cores");
			goto bad;
		    }
		}
		elsif ($setting eq "disk") {
		    $attrkey   = "XEN_EXTRAFS";
		    if ($attrvalue <= 0) {
			# ignore silly user.
			next;
		    }
		    if ($isshared && $attrvalue > 100) {
			$response =
			    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
						 "Bad XEN setting; ".
						 "limited to 100GB extra disk");
			goto bad;
		    }
		}
		else {
		    next;
		}
		$virtexperiment->NewTableRow("virt_node_attributes",
					     {"vname"     => $node_nickname,
					      "attrkey"   => $attrkey,
					      "attrvalue" => $attrvalue });
	    }
	}
	if (defined($fwsettings)) {
	    if (exists($fwsettings->{'style'})) {
		$virtnode->firewall_style($fwsettings->{'style'});
		# 
		# If this is closed, then turn off NFS mounts competely.
		# We do this experiment wide, need per-node setting. 
		#
		if ($fwsettings->{'style'} eq "closed") {
		    $virtexperiment->nonfsmounts(1);
		}
		my $ruleno = 0;
		foreach my $exception (@{ $fwsettings->{'exceptions'} }) {
		    my $port = $exception->{'port'};
		    next
			if ($port !~ /^\d*$/);

		    my $rule = "iptables -A OUTSIDE -p tcp --dport $port ";
		    if (exists($exception->{'ip'})) {
			my $ip = $exception->{'ip'};
			if ($ip eq "myip") {
			    $ip = $ENV{'REMOTE_ADDR'};
			}
			$rule .= "-s $ip ";
		    }
		    $rule .= "-m conntrack --ctstate NEW -j ACCEPT";
		    
		    $virtexperiment->NewTableRow("firewall_rules",
						 {"fwname" => $node_nickname,
						  "ruleno" => $ruleno++,
						  "rule"   => $rule});
		}
	    }
	}

	#
	# Look for general node attributes that pass through to the
	# backend.
	#
	foreach my $attr_ref (GeniXML::GetNodeAttributes($ref)) {
	    $virtexperiment->NewTableRow("virt_node_attributes",
					 {"vname"     => $node_nickname,
					  "attrkey"   => $attr_ref->{'key'},
					  "attrvalue" => $attr_ref->{'value'}});
	}
	
	#
	# Look for node desires that pass through to the backend.
	#
	foreach my $desire_ref (GeniXML::GetNodeDesires($ref)) {
	    $virtexperiment->NewTableRow("virt_node_desires",
				 {"vname"    => $node_nickname,
				  "desire"   => $desire_ref->{'name'},
				  "weight"   => $desire_ref->{'weight'}});
	}
	
	#
	# Local blockstores
	#
	foreach my $blockref (GeniXML::FindNodesNS("n:blockstore",
						   $ref,
				   $GeniXML::EMULAB_NS)->get_nodelist()) {
	    $response = HandleBlockstore($slice_experiment, $virtexperiment,
					 $user, $slice, $ref,
					 $blockref, @$credentials);
	    goto bad
		if (GeniResponse::IsError($response));
	}

	#
	# 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("packet_loss", $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)));

    GeniStitch->LookupAll($rspec);
    
    #
    # Now deal with links for wildcarded nodes. 
    #
    my $linknum = 1;
    my %linkexistsmap = ();
    my %vlan_reservations = ();
    
    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 $ofcontroller = GeniXML::OpenFlowController($linkref);
	my %managers   = ();
	my $ifacenum   = 1;
	my $vindex     = 0;
	my $trivial_ok = 1;

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

	if (exists($linkexistsmap{lc($lanname)})) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Duplicate link $lanname");
	    goto bad;
	}
	$linkexistsmap{lc($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)) {
	    foreach my $mref (GeniXML::FindNodes("n:component_manager",
						 $linkref)->get_nodelist()) {
		my $manager = GetLinkManager($mref);
		# Watch for a bogus name.
		if ($manager eq "") {
		    $response = 
			GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				     "Bad component_manager in link: $lanname");
		    goto bad;
		}
		$managers{$manager} = $manager;
	    }

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

	#
	# Look for a vlan tag reservation request.
	#
	if (my $vlan_tag = GeniXML::GetText("vlantag", $linkref)) {
	    if (! ($vlan_tag =~ /^\d*/)) {
		$response = 
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad vlan tag for $lanname");
		goto bad;
	    }
	    my $result =
		ReserveLocalVlanTag($slice_experiment, $lanname, $vlan_tag);
	    if (GeniResponse::IsResponse($result)) {
		$response = $result;
		goto bad;
	    }
	    # Record newly reserved tags for rollback.
	    if (ref($result)) {
		$vlan_reservations{$lanname} = $result;
	    }
	}

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

	my $isshared = 0;
	my $emulated = 0;
	my $encap    = "default";
	
	#
	# Allow user to turn on link multiplexing. If multiplexing is on
	# then set encapsulation to vlan. Might conflict with stuff below.
	#
	if (GeniXML::IsMultiplexedLan($linkref)) {
	    $emulated = 1;
	    $encap    = "vlan";
	}

	#
	# Look for shared and tagging attributes for the link.
	#
	if (my $shared_vlan = GeniXML::GetSharedLanName($linkref)) {
	    if ($shared_vlan !~ /^[-\w]*$/) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Invalid shared lan name: $shared_vlan");
		goto bad;
	    }
	    my $lanref = Lan->LookupSharedVLanByToken($shared_vlan);
	    if (!defined($lanref)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				 "No such shared lan: $shared_vlan");
		goto bad;
	    }
	    if (!$lanref->{'open'}) {
		#
		# A closed lan, there needs to be a credential to use it.
		#
		my $allowed;
		
		foreach my $cred (@$credentials) {
		    my ($domain, $type, $id) =
			GeniHRN::Parse($cred->target_urn());

		    if ($domain eq $OURDOMAIN && $type eq "vlan" &&
			$id == $lanref->{'lanid'}) {
			$allowed = $cred;
			last;
		    }
		}
		if (!defined($allowed)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
			     "No permission to use shared lan: $shared_vlan");
		    goto bad;
		}
	    }
	    
	    # This is the magic for libvtop.
	    $virtexperiment->NewTableRow("virt_lan_settings",
					 {"vname"   => $lanname,
					  "capkey"  => "sharedvlan",
					  "capval"  => $shared_vlan});
	    $isshared = 1;
	    $encap    = "vlan";
	}
	#
	# Allow user to specify vlan encap, which might override that we
	# just set it above. Experts only please.
	#
	if (GeniXML::HasTagSetting($linkref)) {
	    $encap = (IsTaggedLan($linkref) ? "vlan" : "default");
	    if (IsTaggedLan($linkref)) {
		$trivial_ok = 0;
	    }
	}

	#
	# Allow user to specify best effort.
	#
	my $besteffort = 0;
	
	if (GeniXML::HasBestEffortSetting($linkref)) {
	    $besteffort = 1;
	}

	#
	# Look for general link attributes. We cannot use the
	# virt_lan_settings here, we do not pass them through for
	# regular lans. That needs to be fixed. At the moment,
	# I just need this for Nick zero aging stuff, so make it
	# an environment variable instead. Yuck.
	#
	foreach my $attr_ref (GeniXML::GetLinkAttributes($linkref)) {
	    if ($attr_ref->{'key'} eq "nomac_learning") {
		$virtexperiment->NewTableRow("virt_user_environment",
			     {"name"  => $lanname . "_" . "nomac_learning",
			      "value" => $attr_ref->{'value'} });
	    }
	}

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

	    #
	    # Stitched links always use vlan encap. We could probably
	    # set this latter in the mapper.
	    #
	    if (!$istunnel && exists($external_nodemap{$node_nickname})) {
		$encap = "vlan";
	    }
	    #
	    # If the link includes blockstores, it is a "sanlan" and so
	    # it has to be encap=vlan and best effort.
	    #
	    if (0 &&
		defined($nodetype) && $nodetype->type() eq "blockstore") {
		$encap      = "vlan";
		$trivial_ok = 0;
		$besteffort = 1;
	    }
	}

	my $edgecount = 0;

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

	    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})) {
		my $external_noderef = $external_nodemap{$node_nickname};
		my $manager_id       = GeniXML::GetManagerId($external_noderef);

		#
		# There might be multiple external interfaces for the same
		# lan in the case of "stitch to lan". We only care about the
		# first one we see for each external stitch point.
		#
		next
		    if (exists($external_lanrefs{"${lanname}:${manager_id}"}));
		
		my $stitchpath = GeniStitch->Lookup($lanname, $rspec);
		if (! defined($stitchpath)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					  "$lanname: No stitching path to ".
					  "$node_nickname");
		    goto bad;
		}
		if (defined($stitchpath->error())) {
		    $response = $stitchpath->error();
		    goto bad;
		}

		# XXX: This is completely bogus. There is no current
		# way to map interface refs in the link with
		# individual stitchpoints inside of a stitch path. So
		# we assume lexical order.
		my $edgeiface = $stitchpath->edge_iface($edgecount);
		my $network = $stitchpath->network($edgecount);
		$edgecount += 1;
		if (! defined($edgeiface) || ! defined($network)) {
		    $response =
			GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					     "$lanname: Edge iface mismatch ".
					     "when stitching");
		    goto bad;
		}

		#
		# Look for a vlan tag reservation request. We only
		# support a single tag, not a range.
		#
		my $vlan_tag = $stitchpath->suggested_vlan();
		if ($vlan_tag) {
		    my $result = ReserveLocalVlanTag($slice_experiment,
						     $lanname, $vlan_tag);
		    if (GeniResponse::IsResponse($result)) {
			$response = $result;
			goto bad;
		    }
		    # Record newly reserved tags for rollback.
		    if (ref($result)) {
			$vlan_reservations{$lanname} = $result;
		    }
		}

		#
		# We do this so we can keep track of vport numbers,
		# since we can have multiple links to the same
		# external mode.
		#
		if (!exists($external_vportmap{$node_nickname})) {
		    $external_vportmap{$node_nickname} = 0;
		    
		    #
		    # 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"   => $network->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});
		}
		$iface_name  = $edgeiface->iface();
		$iface_vport = $external_vportmap{$node_nickname};
		$external_vportmap{$node_nickname} += 1;
		$external_linkmap{$lanname} = $linkref;
		$external_lanrefs{"${lanname}:${manager_id}"} = $external_noderef;
		# Allow rspec to provide IP for other side.
		$ip = GeniXML::GetIp($ref, $external_noderef);
	    }
	    else {
		#
		# 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"};

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

	    # 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;
	    my $uselinkdelay = 0;

	    # 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'};
	    }
	    else {
		my @properties = GeniXML::GetLinkProperties($linkref);
		foreach my $property (@properties) {
		    $uselinkdelay = 1;
		    
		    #
		    # Need to make sure we get the correct direction.
		    #
		    my $source   = GetText("source_id", $property);
		    
		    if ($source eq $iface_id) {
			$bandwidth = GetText("capacity", $property)
			    if (defined(GetText("capacity", $property)));
			$latency   = GetText("latency", $property)
			    if (defined(GetText("latency", $property)));
			$lossrate  = GetText("packet_loss", $property)
			    if (defined(GetText("packet_loss", $property)));
			last;
		    }
		}
	    }
	    if ($isshared) {
		# Clear all this on "shared" vlans. Maybe later.
		$bandwidth = 0;
		$latency   = 0.0;
		$lossrate  = 0.0;
	    }
	    if ($besteffort) {
		# Best effort traffic.
		$bandwidth = 10;
		$latency   = 0.0;
		$lossrate  = 0.0;
	    }
	    
	    my $virtlan =
		$virtexperiment->NewTableRow("virt_lans",
					 {"vname"       => $lanname,
					  "vnode"       => $node_nickname,
					  "vport"       => $iface_vport,
					  "vindex"	=> $vindex,
					  "trivial_ok"  => $trivial_ok,
					  "emulated"    => $emulated,
					  "nobwshaping" => $besteffort,
					  "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,
					  "encap_style" => $encap,
					  "fixed_iface" => $iface_name,
					  "uselinkdelay"=> $uselinkdelay,
					 });
	    if ($ofcontroller && $ofcontroller ne "") {
		$virtlan->ofenabled(1);
		$virtlan->ofcontroller($ofcontroller);
	    }
	    $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;
    }

    # Allocate any public address pools.
    if( $slice_experiment->AllocatePublicAddrPools() < 0 ) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "Could not allocate public address pools");
	goto bad;
    }
    
    #
    # This creates the descriptors but does not download the images.
    # Must be done before the mapper runs.
    #
    my $output = GeniUtil::ExecQuiet("$IMAGE_SETUP $pid,$eid");
    if ($?) {
	my $message = "Could not setup images:\n$output";
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef, $message);
	print STDERR $message;
	goto bad;
    }
    print STDERR $output;

    # 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.
    $output = GeniUtil::ExecQuiet("$VTOPGEN -p $pid $eid");
    if ($?) {
	print STDERR "$output\n";
	$response =
	    GeniResponse->Create(GENIRESPONSE_NO_MAPPING, undef,
				 "Could not verify topo:\n$output");
	goto bad;
    }
    $slice_experiment->CleanLogFiles();

    #
    # When doing an initial allocation, we do not want fixnode to bypass
    # normal assign constraint checking, so do not use update mode
    # (the mapper will pass internal option to assign to prevent fixnode).
    #
    my $aopts = ($isupdate ? "-u" : "");
    
    $output =
	GeniUtil::ExecQuiet("$MAPPER -a -d -v $aopts -z -o $tmpfile $pid $eid");
    if ($?) {
	my $logstuff     = "";
	my $errorstr     = "";
	my $solution;
	my $insolution   = 0;
	my $violations;
	my $inviolations = 0;
	my $precheck;
	my $inprecheck   = 0;
	my $insummary    = 0;
	my $errorcode = GENIRESPONSE_ERROR;
	
	unlink($tmpfile);
	if ($isupdate) {
	    $slice_experiment->RemovePhysicalState(1);
	    $slice_experiment->RestorePhysicalState();
	}
	#
	# Find the important lines and print them first if we cannot
	# determine a specific reason and error code. Also copy out
	# everything after Violations until the end of the Solution,
	# in case there are no top level errors
	#
	while ($output =~ /^(.*)$/gm) {
	    my $line = $1 . "\n";

	    #
	    # The assign_wrapper2 script wraps assign, and basically
	    # prints a bunch of stuff a second time. But it helpfully
	    # print a tag line we can watch for. We can stop parsing
	    # when we see it.
	    #
	    last
		if ($line =~ /^ASSIGN FAILED/);

	    # Want just the first set of violations / solution / precheck.
	    if (!defined($precheck) && $line =~ /precheck:$/) {
		$inprecheck = 1;
		$precheck   = "";
	    }
	    elsif ($line =~ /Summary:$/) {
		$insummary = 1;
	    }
	    elsif ($line =~ /End Summary$/) {
		$insummary = 0;
	    }
	    elsif ($insummary &&
		   $line =~ /ram: used=(\d+) total=(\d+)/ && $1 > $2) {
		$errorstr  = "Not enough memory";
		$errorcode = GENIRESPONSE_INSUFFICIENT_MEMORY();
	    }
	    elsif (!defined($violations) &&
		$line =~ /Violations:\s*(\d*)/ && $1 != 0) {
		$violations   = "";
		$inviolations = 1;
		$inprecheck   = 0;
	    }
	    elsif ($inviolations && $line =~ /^Nodes:/) {
		$inviolations = 0;
		$inprecheck   = 0;
		$insolution   = 1;
		$solution     = "";
	    }
	    elsif ($line =~ /^End Solution/i) {
		$inviolations = 0;
		$insolution   = 0;
		$inprecheck   = 0;
	    }
	    if ($inprecheck &&
		$line !~ /^Node/ && $line !~ /^Type/ && $line !~ /^Policy/) {
		
		if ($line =~ /^\*\*\*[\s\w]*precheck failed/) {
		    $errorstr  = "Precheck failure";
		    $errorcode = GENIRESPONSE_NO_MAPPING()
			if ($errorcode == GENIRESPONSE_ERROR());
		}
		elsif ($line =~ /^Annealing/) {
		    $inprecheck = 0;
		}
		else {
		    $precheck .= $line;
		    #
		    # Watch for standard Insufficient message:
		    #
		    # *** 2 nodes of type pc requested, but only 1 available \
		    #          nodes of type pc found
		    #
		    if ($line =~
			/^\s*\*\*\* (\d*) nodes of type ([-\w]*) requested, but/) {
			$errorcode = GENIRESPONSE_INSUFFICIENT_NODES();
		    }
		}
	    }
	    elsif ($inviolations) {
		$violations .= $line;

		# Attempt to parse the violations into something human readable.
		if ($line =~ /no_connect:\s*[1-9]/ ||
		    $line =~ /bandwidth:\s*[1-9]/) {
		    $errorstr  = "Not enough bandwidth to connect some nodes"; 
		    $errorcode = GENIRESPONSE_INSUFFICIENT_BANDWIDTH();
		}
		elsif ($line =~ /pnode_load:\s*[1-9]/) {
		    $errorstr  = "Too many VMs requested on physical host"; 
		    $errorcode = GENIRESPONSE_INSUFFICIENT_NODES();
		}
		elsif ($line =~ /unassigned:\s*[1-9]/) {
		    $errorstr  = "Not enough nodes with fast enough interfaces";
		    $errorcode = GENIRESPONSE_INSUFFICIENT_NODES();
		}
	    }
	    elsif ($insolution) {
		$solution .= $line;
	    }
	    elsif ($line =~ /^\*\*\*/) {
		#
		# Other bad things marked by ***
		#
		$logstuff .= $line;
	    }
	}

	#
	# We send back as little as what we think might be useful to
	# the user, but the entire error output lands in the log file.
	#
	$logstuff .= $precheck
	    if (defined($precheck));
	$logstuff .= $solution
	    if (defined($solution));
	
	# 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";
	}

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

	$response =
	    GeniResponse->Create($errorcode,
				 "Could not map to resources" .
				 ($errorstr ne "" ? ": $errorstr" : ""),
				 $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);
	my $sliver_type    = GeniXML::GetText("sliver_type", $ref);

	#
	# Watch for storage hosts and skip.
	#
	next
	    if (defined($sliver_type) && $sliver_type eq "pcsanhost");

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

	# Set sliver urns in ticket
	my $sliver_idx = TBGetUniqueIndex('next_sliver', 1);
	my $sliver_urn = GeniHRN::Generate( "@OURDOMAIN@", "sliver", $sliver_idx );
	
	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'});
	    GeniXML::SetText("sliver_urn", $rspec, $sliver_urn);
	} 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::SetText("sliver_id", $rspec, $sliver_urn);
	}
	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 $stitchpath   = GeniStitch->Lookup($linkname);
	my $slice_urn = $slice->urn();
	my $retries   = 10;

	if (! defined($stitchpath)) {
	    $response =
		GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				     "$linkname: No stitching path");
	    goto bad;
	}
	if (defined($stitchpath->error())) {
	    $response = $stitchpath->error();
	    goto bad;
	}

	my $chainmode = ($stitchpath->mode() eq "chain" ? 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 @candidates = $stitchpath->vlan_list();
		my @tags       = ();
		my $i = 0;
		for ($i = 0; $i < scalar(@candidates) && $i < 50; $i++) {
		    my $t = $candidates[$i];
		    push(@tags, $t)		
			if (VLan->VlanTagAvailable($t));
		}
		if (!@tags) {
		    print STDERR "No candidate vlan tags for $linkname\n";
		    print STDERR "@candidates\n";
		    print STDERR Dumper($stitchpath);
		    $vlan->Destroy()
			if ($madevlan);
		    $response =
			GeniResponse->Create(GENIRESPONSE_VLAN_UNAVAILABLE,
					     undef,
				"Error reserving vlan tag for $linkname");
		    goto bad;
		}
		print STDERR
		    "Trying to allocate one tag for $linkname: @tags\n";
		system("$SNMPIT -A ".
		       "$pid $eid $lanid," . join(",", @tags));
		if ($?) {
		    $vlan->Destroy()
			if ($madevlan);
		    $response =
			GeniResponse->Create(GENIRESPONSE_VLAN_UNAVAILABLE,
					     undef,
				 "Error reserving 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_VLAN_UNAVAILABLE,
						 undef,
				 "Error reserving vlan tag for $linkname");
		goto bad;
	    }
	    print STDERR "Got tag $tag for $linkname\n";
	    print STDERR "$linkref\n";
	    
	    GeniXML::SetText("vlantag", $linkref, $tag);

	    #
	    # Change all of the stitching hops to our edge point, since
	    # that is how our network is setup.
	    #
	    my @hoplist = @{ $stitchpath->hoplist() };
	    foreach my $hop (@hoplist) {
		my $hopurn = GetHopLinkID($hop);
		my ($auth,undef,undef) = GeniHRN::Parse($hopurn);
		next
		    if (!defined($auth) || $auth ne $OURDOMAIN);

		GeniXML::SetVlanTagInHop($hop, $tag);
	    }
	    next;	    
	}

	#
	# Chainmode
	#
	while ($retries) {
	    my $stitchpath   = GeniStitch->Lookup($linkname);
	    if (! defined($stitchpath)) {
		$response =
		    GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "$linkname: No stitching path to ");
		    goto bad;
	    }
	    if (defined($stitchpath->error())) {
		$response = $stitchpath->error();
		goto bad;
	    }
	    
	    #
	    # 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.
	    #
	    # If we just reserved the tag above, we still need to talk
	    # to the other side.
	    #
	    my $tag = VLan::GetReservedVlanTag($slice_experiment, $linkname);
	    last
		if (defined($tag) && !exists($vlan_reservations{$linkname}));

	    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);
	    my $networkid = $stitchpath->network_id();
	    system("$RESERVEVLANS ".
		   "'$slice_urn' '$linkname' '$networkid' $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);

		    #
		    # Change all of the stitching hops to our edge point, since
		    # that is how our network is setup.
		    #
		    my @hoplist = @{ $stitchpath->hoplist() };
		    foreach my $hop (@hoplist) {
			my $hopurn = GetHopLinkID($hop);
			my ($auth,undef,undef) = GeniHRN::Parse($hopurn);
			next
			    if (!defined($auth) || $auth ne $OURDOMAIN);

			SetVlanTagInHop($hop, $tag);
		    }
		    last;
		}
		# This should not happen. 
		print STDERR "Did not find the reserved tag for $linkname\n";
		$response = GeniResponse->Create(GENIRESPONSE_VLAN_UNAVAILABLE,
						 undef,
				 "Error reserving vlan tag for $linkname");
		goto bad;
	    }
	    # Try again.
	  again:
	    $retries--;
	}
	if (!$retries) {
	    $response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				 "Could not reserve vlan tag for $linkname");
	    goto bad;
	}
    }
    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);
    $newticket->SetSpeaksFor($speaksfor)
	if (defined($speaksfor));
    
    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));
    }
    #
    # Clear any new vlan tag reservations we made during this call.
    #
    foreach my $linkname (keys(%vlan_reservations)) {
	my ($lanid, $vlan_tag) = @{ $vlan_reservations{$linkname} };

	# If this is a new ticket, there is no lan object yet,
	# so need to call this as a function instead of a method.
	VLan::ClearReservedVlanTag($lanid, $vlan_tag);
    }
    if ($v2 && $level == 0) {
	CleanupDeadSlice($slice, 1)
	    if (defined($slice));
	return $response;
    }
    $slice->UnLock()
	if (defined($slice));
    $ticket->UnLock()
	if (defined($ticket) && $ticket->stored());
    return $response;
}

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

    return SliverWork($argref, 0);
}

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

    return SliverWork($argref, 1);
}

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

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

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

    my $ticket = CheckTicket($ticketstr, $credential->target_urn());
    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, undef);
}

sub SliverWorkAux($$$$$$$$)
{
    my ($credential, $object,
	$keys, $isupdate, $impotent, $v2, $level, $speaksfor) = @_;
    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) {
	# Lookup by sliver (if provided with sliver credential)
	$aggregate = GeniAggregate->Lookup($credential->target_urn());
	if (defined($aggregate)) {
	    $slice = $aggregate->GetSlice();
	} else {
	    # Otherwise, this might be a slice credential
	    $slice = GeniSlice->Lookup($credential->target_urn());
	    if (defined($slice)) {
		$aggregate = GeniAggregate->SliceAggregate($slice);
	    }
	}
	if (!defined($slice)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No local slice found");
	}
	if (!defined($aggregate)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"No local sliver/aggregate 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) {
	$slice->UnLock();
	$ticket->UnLock()
	    if (defined($ticket));
	
	print STDERR "Error flipping to real user\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "FlipToUser Error");
    }
    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 (GeniResponse::IsResponse($expires)) {
	    $message = "Illegal valid_until in rspec";
	    goto bad;
	}
	my $tmp = SetSliceExpiration($slice, $expires, 0, 0, $credential);
	if (GeniResponse::IsResponse($tmp)) {
	    $message = GeniResponse::output($tmp);
	    goto bad;
	}
    }

    my %phys2nickname = ();

    #
    # 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);
	my $virt_subtype  = GeniXML::GetVirtualizationSubtype($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;
	}

	#
	# Keep track of mapping between component_id and client_id to
	# reject requests that change the client_id bound to a
	# component_id.
	if ($virt_subtype eq "raw" || $virt_subtype eq "raw-pc") {
	    $phys2nickname{$resource_id} = $node_nickname;
	}
	
	#
	# 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;
	    }
	    my $phys = $sliver->resource_urn();
	    if (exists($phys2nickname{$phys})
		&& $phys2nickname{$phys} ne $nickname) {
		$message = "Cannot bind node " . $phys2nickname{$phys} .
		    " to the same physical node which was bound to " .
		    $nickname;
		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());
	$experiment->SetState(EXPTSTATE_ACTIVATING());
    }
    $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 ($MAINSITE && $node->sharing_mode()) {
	    my $physhost = $node->GetPhysHost();
	    if (defined($physhost)) {
		my ($osinfo) = $physhost->RunningOsImage();
		if (defined($osinfo) && $osinfo->FeatureSupported("xen-host")){
		    $node->NoNFSMounts();
		}
	    }
	}
	
	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(\$message,
							$slice,
							$owner,
							$node1sliver,
							$node2sliver,
							$linkref,
							$node1rspec,
							$node2rspec);
		if (!defined($tunnel)) {
		    $message = "Could not create aggregate for $linkname" .
			(defined($message) ? ": $message" : "");
		    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();
	    }
	    elsif (defined($interface)) {
		$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})) {
		# Update interface in the node section.
		$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);
	
    }
    #
    # We have to go back through the nodes and store the manifest again,
    # since we might have changed the interfaces down inside the node in
    # the loop above. 
    #
    foreach my $ref (GeniXML::FindNodes("n:node",
					$manifest)->get_nodelist()) {
	my $node_id = GeniXML::GetVirtualId($ref);

	if (exists($nodemap{$node_id})) {
	    my $nodesliver = $nodemap{$node_id};

	    if ($nodesliver->UpdateRspec($ref)) {
		print STDERR "Could not store manifest for $nodesliver\n";
	    }
	}
    }
  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;
    }

    my $siteinfo = GeniXML::FindFirst("n:site_info", $manifest);
    if (defined($siteinfo)) {
	# Clean old location.
	$manifest->removeChild($siteinfo);
    }
    $siteinfo = GeniXML::AddElement("site_info", $manifest,
				    $GeniXML::SITEINFO_NS);
    my $location = GeniXML::AddElement("location", $siteinfo);
    GetSiteVar('general/default_longitude', \$default_longitude)
	if (!defined($default_longitude));
    GetSiteVar('general/default_latitude', \$default_latitude)
	if (!defined($default_latitude));
    GetSiteVar('general/default_country', \$default_country)
	if (!defined($default_country));
    if (defined($default_country) &&
	defined($default_latitude) && defined($default_longitude)) {
	GeniXML::SetText("country", $location, $default_country);
	GeniXML::SetText("latitude", $location, $default_latitude);
	GeniXML::SetText("longitude", $location, $default_longitude);
    }

    AnnotateAddressPools($manifest, $experiment);
    
    #
    # Record all manifests (including updates) in the history. 
    #
    if (GeniUsage->NewManifest($aggregate, $manifest, $rspec)) {
	print STDERR "GeniUsage->NewManifest($aggregate) failed\n";
    }
    $aggregate->SetSpeaksFor($speaksfor)
	if (defined($speaksfor));
    
    #
    # 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();

	# Update this info now that we are done. 
	$experiment->SaveExperimentState();
	$experiment->SaveLogFiles();
	
	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();

    # Update this info now that we are done. 
    $experiment->SaveExperimentState();
    $experiment->SaveLogFiles();
    
    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 = GeniCredential::CheckCredential($credstr);
    return $credential
	if (GeniResponse::IsResponse($credential));

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

sub RenewSliverAux($$$)
{
    my ($credentials, $expires, $alap) = @_;
    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;
    }
    #
    # We do not save renew logs, so add a metadata tag with the
    # expiration so we can see what the user actually tried to do.
    #
    main::AddLogfileMetaData("renew_request", $expires);
    
    my $response = SetSliceExpiration($slice,
				      $expires, 0, $alap, @{ $credentials });
    if (GeniResponse::IsError($response)) {
	$slice->UnLock();
	return $response;
    }
    main::AddLogfileMetaData("renew_granted", $slice->ExpirationGMT());
    
    #
    # Need to delete any cached credentials.
    #
    my $aggregate = GeniAggregate->SliceAggregate($slice);
    if (defined($aggregate)) {
	GeniCredential->DeleteForTarget($aggregate);
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $slice->ExpirationGMT());

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

    my $ticket = CheckTicket($tickstr, $credential->target_urn());
    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 = GeniCredential::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) {
	$slice->UnLock();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start sliver/aggregate");
    }
    $slice->UnLock();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

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

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

    if (!defined($cred)) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS);
    }
    my $credential = GeniCredential::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 = GeniCredential::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 = GeniCredential::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 = GeniCredential::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 = GeniCredential::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 = GeniCredential::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_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 = GeniCredential::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 = GeniCredential::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() ||
	       $node->eventstate() eq TBDB_NODESTATE_RELOADFAILED()) {
	    $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 = GeniCredential::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 = GeniCredential::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() ||
	       $node->eventstate() eq TBDB_NODESTATE_RELOADFAILED()) {
	    $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 = GeniCredential::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));

	#
	# The above is the common case, but we need to support regen
	# of the certificate, which will change the version number.
	# Which means a straight comparison will fail. So look to see
	# if the UUID is the same. If so, we store the new certificate.
	#
	# We should possibly check the public key as well, but I am
	# going to punt on that for now.
	#
	if ($certificate->uuid() eq $slice->uuid()) {
	    print STDERR "Updating certificate for $slice to $certificate\n";
	    $slice->GetCertificate()->Delete();
	    $slice->Flush();
	    $certificate->Store();
	    $slice = GeniSlice->Lookup($certificate->urn());
	    if (!defined($slice)) {
		return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Problem updating slice certificate");
	    }
	}

	# 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");
    }
    # Sanity check.
    if (! defined($credential->expires())) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				"Slice credential does not have an expiration");
    }
    $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 $initial_sliver_lifetime = 0;
    if (!GetSiteVar('protogeni/initial_sliver_lifetime',
		    \$initial_sliver_lifetime)) {
	# Cannot get the value, default it to 6 hours.
	$initial_sliver_lifetime = 6;
    }
    elsif ($initial_sliver_lifetime == 0) {
	$initial_sliver_lifetime = $max_sliver_lifetime * 24;
    }
    my $expires = $credential->expires();
    # This is already a localtime.
    my $when = eval { timelocal(strptime($expires)); };
    if ($@) {
	$expires = time() + (3600 * $max_sliver_lifetime);
    }
    else {
	my $diff = $when - time();

	if ($diff > (3600 * 24 * $max_sliver_lifetime)) {
	    # Shorten to policy maximum. Okay to use a unix time.
	    $expires = time() + (3600 * $max_sliver_lifetime);
	}
    }
    $slice->SetExpiration($expires);
    $slice->SetPublicID();
    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();
    my $email = $certificate->email();

    # Local users always exist, so pass flag.
    my $user = GeniUser->Lookup($certificate->urn(), 1);
    if (defined($user)) {
	if ($PROTOGENI_LOCALUSER && !$user->IsLocal()) {
	    $user = User->LookupNonLocal($urn);
	    if (defined($user)) {
		return GeniUser->CreateFromLocal($user);
	    }
	    # Already exists as a geni user, need to make a real user.
	    return GeniUtil::CreateLocalUser($urn, $email);
	}

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

	#
	# Oh, but if this is a local user, we already have the
	# updated certificate in the DB (we get it from tbdb),
	# so no point in changing and we do not want to store it!
	#
	if ($user->IsLocal()) {
	    return $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 $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;
    }
    if ($PROTOGENI_LOCALUSER) {
	return GeniUtil::CreateLocalUser($urn, $email);
    }
    $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" || $id eq "ma"))) {
	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";
	$aggregate->SetRegistered(1);
	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));

    my $creator = GeniUser->Lookup($slice->creator_uuid(), 1);
    if (!defined($creator)) {
	print STDERR "CleanupDeadSlice: Could not find creator\n";
	return -1;
    }
    if (!defined(FlipToUser($slice, $creator))) {
	print STDERR "CleanupDeadSlice: Could not flip to user\n";
	return -1;
    }

    #
    # If a monitor process is running, then cancel it so that
    # we do not leave it behind on a slice/experiment that is
    # now gone.
    #
    if ($slice->monitor_pid()) {
	my $response = KillMonitor($slice);
	if (GeniResponse::IsResponse($response)) {
	    print STDERR "CleanupDeadSlice: Could not kill monitor process\n";
	    return -1;
	}
    }

    # print "Cleaning up dead slice $slice\n";
    my $slice_uuid = $slice->uuid();
    my $experiment = $slice->GetExperiment();

    if (defined($experiment)) {
	#
	# Do not allow a paniced slice to be terminated until the panic
	# is cleared. 
	#
	if ($experiment->state() eq EXPTSTATE_PANICED() ||
	    # Need this cause we are not locking. We need to lock.
	    $experiment->paniced()) {
	    print STDERR "Refusing to terminate a paniced experiment\n";
	    return -1;
	}
	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;
	}

	#
	# If this experiment has shared a lan to others, then must
	# revoke them. This will yank them out from underneath the
	# slices using them, but thats the way it has to be.
	#
	if ($experiment->SharingVlans()) {
	    my @sharedvlans = ();
	    if ($experiment->SharedVlanList(\@sharedvlans)) {
		print STDERR "Failed to get shared VLANs\n";
		return -1;
	    }
	    while (@sharedvlans) {
		my $vlan  = shift(@sharedvlans);
		my $vname = $vlan->vname();
		print STDERR "Unsharing vlan $vname in $pid,$eid\n";
		#
		# This operation has to be done as an admin person. 
		#
		GeniUtil::FlipToElabMan();
		system("$WAP $SHAREVLAN -r -f $pid,$eid $vname");
		my $ecode = $?;
		FlipToUser($slice);
		if ($ecode) {
		    print STDERR "Failed to unshare vlan!\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 $eid;

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

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

    # Get the project and group.
    my $group = GeniUtil::GetHoldingProject($urn, $creator);
    return $group
	if (GeniResponse::IsResponse($group));

    my $project = $group->GetProject();
    my $pid = $project->pid;
    my $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");
    }

    #
    # Look to see if this eid is already in use. Normally we do not
    # allow this, but if the slice urn has a subauthority, we really
    # do want to accept it, since it would be really confusing for
    # users otherwise.
    #
    $experiment = Experiment->Lookup($project->pid(), $eid);
    if (defined($experiment)) {
	if (!defined($group)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Slice name already exists");
	}
	my $digest = sha1_hex($urn);
	$digest = substr($digest, 0, 8);
	$eid = lc("e${digest}");
	if (! Experiment->ValidEID($eid)) {
	    print STDERR "Cannot form a unique eid for $urn\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Cannot form a unique eid");
	}
	$experiment = Experiment->Lookup($project->pid(), $eid);
	if (defined($experiment)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Slice name already exists");
	}
	print STDERR "Converted $urn to unique eid $eid\n";
    }

    #
    # 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());
    }
    my $creator_arg = ($PROTOGENI_LOCALUSER ? "-C " . $creator->uid() : "");

    # 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' ".
	   "-h '$uuid' $creator_arg -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));
    my $group   = $project;
    my $creator = $experiment->GetCreator();
    return undef
	if (!defined($creator));
    $creator = GeniUser::LocalUser->Create($creator);

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

	$creator = User->Lookup("geniuser");
	return undef
	    if (!defined($creator));
	$user = GeniUser::LocalUser->Create($creator);
	goto flip;
    }

    #
    # 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()) {
	$user = $creator;
	goto flip;
    }
    
    #
    # 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 or if the
    # creator binds a user to a slice. 
    #
    if (!$experiment->AccessCheck($user->emulab_user(),
				  $Experiment::EXPT_ACCESS_MODIFY)) {
	$user = $creator;
    }
  flip:
    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 CheckTicket($$)
{
    my $ticket = GeniTicket->CreateFromSignedTicket($_[0]);
    my $slice_urn = $_[1];
    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 is associated with the slice URN
    #
    if ($ticket->slice_urn() ne $slice_urn) {
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				    "This ticket does not belong to your slice");
    }

    #
    # 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 (ref($ref) ne "HASH");
	    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 ReserveLocalVlanTag($$$)
{
    my ($experiment, $lanname, $tag) = @_;
    my $createdvlan = 0;
    
    my $vlan = VLan->Lookup($experiment, $lanname);
    #
    # Do we already have the link and tag?
    #
    if (defined($vlan)) {
	if ($vlan->HasVlanTagReserved($tag)) {
	    # Indicates tag already reserved. 
	    return 0;
	}
	#
	# Not allowed to change the tag, sorry.
	#
	if ($vlan->GetReservedVlanTag()) {
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Already have a tag for $lanname");
	}
    }
    else {
	#
	# If this is an update to a ticket, there is no lan
	# object, it is still uninstantiated. 
	#
	my $curtag = VLan::GetReservedVlanTag($experiment, $lanname);
	if (defined($curtag)) {
	    if ($curtag == $tag) {
		# Indicates tag already reserved. 
		return 0;
	    }
	    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					"Already have a tag for $lanname");
	}
    }
	    
    #
    # Lets see if the tag is available.
    #
    if (!VLan->VlanTagAvailable($tag)) {
	my $optmsg = "";
	my $info = VLan->ReservedVlanArrayByTag($tag);
	if (defined($info) &&
	    $info->{'exptidx'} == $experiment->idx()) {
	    $optmsg = ": already in use by link '" . $info->{'vname'} . "'";
	}
	return GeniResponse->Create(GENIRESPONSE_VLAN_UNAVAILABLE, undef,
		    "vlan tag $tag for '$lanname' not available${optmsg}");
    }

    #
    # Reserve the tag. In order to do this, we have to create
    # a lan entry long enough for snmpit to actually create the
    # reservation. Then we kill it off until the ticket is actually
    # redeemed.
    #
    if (!defined($vlan)) {
	$vlan = VLan->Create($experiment, $lanname);
	if (!defined($vlan)) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Internal Error creating vlan object");
	}
	$createdvlan = 1;
    }
    my $lanid = $vlan->lanid();
    my $pid   = $experiment->pid();
    my $eid   = $experiment->eid();

    print STDERR "Trying to reserve vlan tag $tag for $lanname\n";
    system("$SNMPIT -A $pid $eid $lanid,$tag");
    if ($?) {
	$vlan->Destroy()
	    if ($createdvlan);
	return GeniResponse->Create(GENIRESPONSE_VLAN_UNAVAILABLE, undef,
				    "Error reserving vlan tag for $lanname");
    }
    $vlan->Destroy()
	if ($createdvlan);
    print STDERR "Reserved tag $tag for $lanname\n";
    return [$lanid, $tag];
}

#
# Check the monitor process, clear it if it died.
#
sub CheckMonitor($)
{
    my ($slice) = @_;
    my $pid = $slice->monitor_pid();

    #
    # See if the process still exists.
    #
    if (kill(0, $pid) == 0) {
	if ($!{ESRCH}) {
	    print STDERR "Monitor process $pid no longer exists.\n";
	    $slice->ClearMonitorPid();
	    return 0;
	}
    }
    return 0;
}

#
# Kill the monitor process.
#
sub KillMonitor($)
{
    my ($slice) = @_;
    my $pid = $slice->monitor_pid();

    return 0
	if (!$pid);

    my $experiment = $slice->GetExperiment();
    if (!defined($experiment)) {
	print STDERR "No experiment for $slice\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No slice experiment");
    }
    #
    # See if the process still exists.
    #
    if (kill(0, $pid) == 0) {
	if ($!{ESRCH}) {
	    print STDERR "Monitor process $pid no longer exists.\n";
	    $experiment->SetCancelFlag(0);
	    $slice->ClearMonitorPid();
	    return 0;
	}
	# What does getting here mean?
    }
	
    print STDERR "Monitor in progress: process id $pid ...\n";

    if ($experiment->canceled()) {
	print STDERR "Cancel flag already set for $experiment\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Unable to stop monitor");
    }
    #
    # Okay, before we commit to waiting for something that might
    # not happen, or erroneously setting the cancel flag, lets lock
    # the tables and check again, to avoid race in start/restart.
    #
    $slice->LockTables();
    if ($slice->GetMonitorPid()) { 
	$experiment->SetCancelFlag(1);
	$slice->UnLockTables();

	#
	# Wait for the monitor to go away, but should not take long.
	#
	my $count = 6;
	while ($count > 0) {
	    sleep(5);
	    # Go to the DB.
	    my $monitor_pid = $slice->GetMonitorPid();
	    last
		if (! $monitor_pid);
	    $count--;
	}
	if ($slice->GetMonitorPid()) {
	    print STDERR "Monitor process $pid would not die!\n";
	    SENDMAIL($TBOPS, "Monitor for slice would not die!",
		     "Monitor would not die: $slice\n\n" .
		     "$TBBASE/showslice.php?slice_idx=" . $slice->idx() .
		     "&showtype=cm",
		     $TBOPS);
	    print STDERR "Could not shutdown $slice!\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Monitor would not die");
	}
    }
    else {
	$slice->UnLockTables();
    }
    return 0;
}

#
# Helper function to compute expiration time.
#
# alap => extend as long as possible
#
sub SetSliceExpiration($$$$@)
{
    my ($slice, $expiration, $checkonly, $alap, @credentials) = @_;
    my $message     = "Error renewing sliver";
    my $when;
    
    #
    # Ick, assume first credential is the slice credential. Bad.
    #
    my $slice_credential = shift(@credentials);
    
    #
    # Maximum expiration is what the credential says, but we might
    # not allow that long.
    #
    my $slice_expires = $slice_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. zero means no limit.
    #
    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 for what resources in use; If only VMs, allow longer
    #
    my $slice_experiment = $slice->GetExperiment();
    if ($slice_experiment && !$slice_experiment->HasPhysNodes()) {
	$max_sliver_lifetime = 90
	    if ($max_sliver_lifetime && $max_sliver_lifetime < 90);
    }
    
    #
    # Check if the user has a credential that lets him obtain slivers
    # with extended sliver lifetime. If so allow request, but note
    # that this will not allow an override of the DB settings.
    #
    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;
	}
    }

    if (defined($expiration)) {
	# Gack, why does Frontier do this. It is stupid.
	if (ref($expiration) eq 'Frontier::RPC2::DateTime::ISO8601') {
	    $expiration = $expiration->value;
	}
	
	# Convert to a localtime.
	$when = eval { timegm(strptime($expiration)); };
	if ($@) {
	    $message = $@;
	    goto bad;
	}
	if (!defined($when)) {
	    $message = "Could not parse expiration";
	    goto bad;
	}
    }
    else {
	$when = $slice_expires;
    }
    my $diff = $when - time();
    
    if ($diff < (60 * 5)) {
	$message = "such a short life for a sliver?";
	goto bad;
    }
    if ($when > $slice_when) {
	$message = "expiration is greater then slice expiration";
	goto bad;
    }
    if ($when < time()) {
	$message = "expiration is in the past; no time travel allowed";
	goto bad;
    }
    if (defined($slice->renew_limit()) &&
	$diff > $slice->renew_limit_stamp()) {
	if ($slice->renew_limit_stamp() == 0) {
	    $message = "you are not allowed to renew cause it ".
		"was idle for too long";
	}
	else {
	    $message = "expiration increment is greater then local slice ".
		"setting: " . $slice->renew_limit();
	}
	goto bad;
    }
    if (defined($slice->expiration_max())) {
	if ($when > $slice->expiration_max_stamp()) {
	    $message = "expiration is greater then local slice setting: ".
		POSIX::strftime("20%y-%m-%dT%H:%M:%SZ",
				gmtime(str2time($slice->expiration_max())));
	    goto bad;
	}
    }
    elsif ($max_sliver_lifetime &&
	   $diff > (3600 * 24 * $max_sliver_lifetime)) {
	if ($alap) {
	    $when = time() + (3600 * 24 * $max_sliver_lifetime);
	}
	else {
	    $message = "expiration increment is greater then the maximum ".
	    "number (" . (60 * 24 * $max_sliver_lifetime) . ") of minutes";
	    goto bad;
	}
    }
    if (!$checkonly && $slice->SetExpiration($when) != 0) {
	$message = "could not set expiration time";
	goto bad;
    }
    return 0;
    
  bad:
    return GeniResponse->Create(GENIRESPONSE_REFUSED, undef, $message);
}

#
# Handle BlockStores. 
#
sub HandleBlockstore($$$$$$@)
{
    my ($experiment, $virtexperiment,
	$geniuser, $slice, $noderef, $blockref, @credentials) = @_;
    my $errorcode = GENIRESPONSE_ERROR;
    my $message   = "Unknown Error";
    my $nodename  = GeniXML::GetVirtualId($noderef);
    my @attributes = ();

    require Image;
    require Lease;
    require Blockstore;

    my $bsname    = GeniXML::GetText("name", $blockref);
    my $class     = GeniXML::GetText("class", $blockref);
    my $mount     = GeniXML::GetText("mountpoint", $blockref);
    my $readonly  = GeniXML::GetText("readonly", $blockref);
    my $dataset_id= GeniXML::GetText("dataset", $blockref);
    my $placement = GeniXML::GetText("placement", $blockref);
    my $btype     = "";
    my $fixed     = $nodename;
    my $size      = 0;

    if (!defined($class) || !($class eq "local" || $class eq "remote")) {
	$message = "Illegal blockstore class";
	goto bad;
    }
    if ($class eq "local") {
	if (!defined($bsname)) {
	    $message = "Local blockstores must be named";
	    goto bad;
	}
	if (!TBcheck_dbslot($bsname, "blockstores", "bs_id",
			    TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    $message = "Illegal blockstore name: $bsname";
	    goto bad;
	}
    }
    if (!defined($mount)) {
	$message = "Missing blockstore mount point";
	goto bad;
    }
    if (!defined($readonly)) {
	$readonly = 0;
    }
    else {
	$readonly = ($readonly eq "true" ? 1 : 0);
    }
    if (defined($placement)) {
	if (lc($placement) !~ /^(any|sysvol|nonsysvol)$/i) {
	    $message = "Improper placement: $placement";
	    goto bad;
	}
	$placement = uc($placement);
    }
    else {
	$placement = "ANY";
    }
    #
    # If ephemeral, size must be given. Else we get it below from the lease,
    # or we get it from the image if its an image backed blockstore.
    #
    if ($class eq "local") {
	if (!defined($dataset_id)) {
	    $size = GeniXML::GetText("size", $blockref);
	
	    if (!defined($size)) {
		$message = "Missing blockstore size for $bsname";
		goto bad;
	    }
	}
	else {
	    # Default project to lookup.
	    my $pid = $experiment->pid();
	    my $gid = $pid;
	    my $vers;
	    my $image;
	
	    #
	    # Is it a url. We might not have the image locally, but
	    # will later when image_setup runs. But lets do a check to
	    # make sure it really exist by trying to import it. This will
	    # get the descriptor and the information we need.
	    #
	    if ($dataset_id =~ /^(ftp|http|https):/) {
		if (!TBcheck_dbslot($dataset_id, "virt_nodes", "osname",
				TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		    $message = "Invalid url for dataset";
		    goto bad;
		}
		$image = Image->LookupByURL($dataset_id);
		if (!defined($image)) {
		    my $safe_url = User::escapeshellarg($dataset_id);

		    print STDERR "$dataset_id is not here, trying to get it\n";
		    system("$IMAGE_IMPORT -p $pid $safe_url");
		    if ($?) {
			$message = "Could not import $dataset_id";
			goto bad;
		    }
		    $image = Image->LookupByURL($dataset_id);
		    if (!defined($image)) {
			$message = "Could not lookup dataset after import";
			goto bad;
		    }
		}
	    }
	    elsif (GeniHRN::IsValid($dataset_id)) { 
		my ($domainsubauth,$dtype,$id) = GeniHRN::Parse($dataset_id);
		if ($dtype ne "dataset") {
		    $message = "Illegal dataset urn for $dataset_id";
		    goto bad;
		}
		my ($domain,$subauth) = split(":", $domainsubauth);
		if ($domain ne $OURDOMAIN) {
		    $message = "This is not the correct site for this dataset";
		    goto bad;
		}
		if (defined($subauth)) {
		    $pid = $subauth;
		}
		if ($id =~ /^([^\/]+)\/\/([^\/]+)(\/\/(\d+))?$/) {
		    $id  = $2;
		    if (defined($4)) {
			$vers = $4;
		    }
		}
		$image = Image->Lookup($pid, $id, $vers);
		if (!defined($image)) {
		    $message = "Unknown dataset: $dataset_id";
		    goto bad;
		}
	    }
	    else {
		$message = "Invalid name/url for dataset";
		goto bad;
	    }
	    if (!$image->isdataset()) {
		$message = "Not a dataset: $dataset_id";
		goto bad;
	    }
	    if ($PROTOGENI_LOCALUSER) {
		#
		# We use the Emulab permission system.
		#
		if (!$image->AccessCheck($geniuser->emulab_user(),
					 TB_IMAGEID_READINFO())) {
		    $message = "Not enough permission to use $dataset_id";
		    $errorcode = GENIRESPONSE_FORBIDDEN;
		    goto bad;
		}
	    }
	    else {
		#
		# The image must be in the current project, or it must
		# be global (okay, shared).
		#
		if (! ($image->global() ||
		       $image->pid() eq $experiment->pid())) {
		    $message = "Not enough permission to use $dataset_id";
		    $errorcode = GENIRESPONSE_FORBIDDEN;
		    goto bad;
		}
	    }
	    push(@attributes, ["dataset", $image->versname(), 0]);
	    $btype = "imdataset";
	    
	    if (! ($image->lba_low() || $image->lba_high())) {
		$message = "No local size info for $dataset_id";
		goto bad;
	    }
	    $size = int(($image->lba_high() -
			 $image->lba_low() + 1) /
			(1024 / $image->lba_size())) . "KB";
	}
	$size = Blockstore::ConvertToMebi($size);
	if ($size < 0) {
	    $message = "Illegal blockstore size for $bsname";
	    goto bad;
	}
    }
    push(@attributes, ["mountpoint", $mount, 0]);
    push(@attributes, ["placement", $placement, 0]);
    push(@attributes, ["readonly", $readonly, 0]);
    push(@attributes, ["class", ($class eq "local" ? "local" : "SAN"), 1]);
	
    if ($class eq "remote") {
	$fixed = $bsname = $nodename;
	push(@attributes, ["protocol", "iSCSI", 1]);

	if (defined($dataset_id)) {
	    # Default project to lookup lease.
	    my $pid = $experiment->pid();
	    my $gid = $pid;
	
	    #
	    # Look for a urn and possibly project/group qualified lease name.
	    #
	    if (GeniHRN::IsValid($dataset_id)) {
		my ($domainsubauth,$ltype,$id) = GeniHRN::Parse($dataset_id);
		if ($ltype ne "dataset") {
		    $message = "Illegal dataset urn for $dataset_id";
		    goto bad;
		}
		my ($domain,$subauth) = split(":", $domainsubauth);
		if ($domain ne $OURDOMAIN) {
		    $message = "This is not the correct site for this dataset";
		    goto bad;
		}
		if (defined($subauth)) {
		    $pid = $subauth;
		}
		$dataset_id = $id;

		if ($dataset_id =~ /^(.*)\/\/(.*)$/) {
		    $gid = $1;
		    $dataset_id = $2;
		}
		if (!TBcheck_dbslot($dataset_id, "project_leases", "lease_id",
				TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
		    $message = "Illegal dataset name: $dataset_id";
		    goto bad;
		}
	    }
	    my $lease = Lease->Lookup($pid, $gid, $dataset_id);
	    if (!defined($lease)) {
		#
		# Dataset must already exist.
		#
		$message = "No such dataset for $bsname: $dataset_id";
		$errorcode = GENIRESPONSE_SEARCHFAILED;
		goto bad;
	    }
	    if ($PROTOGENI_LOCALUSER) {
		#
		# We use the Emulab permission system.
		#
		goto permokay
		    if ($lease->AccessCheck($geniuser->emulab_user(),
					    LEASE_ACCESS_READ()));
		$message = "Not enough permission to use dataset: $dataset_id";
		$errorcode = GENIRESPONSE_FORBIDDEN;
		goto bad;
	    }
	    # Local user can use their own local lease. 
	    goto permokay
		if ($geniuser->IsLocal() &&
		    $lease->owner_uid() eq $geniuser->uid());
	    
	    #
	    # Permission checks are a work in progress. Datasets created by
	    # the same authority domain as the slice can be used. This is
	    # explicit in the slice pid/gid and the lease pid/gid, which
	    # reflect the domains.
	    #
	    if ($experiment->pid() ne $lease->pid()) {
		$message = "Not allowed to use dataset from a ".
		    "different SA: $dataset_id";
		$errorcode = GENIRESPONSE_FORBIDDEN;
		goto bad;
	    }
	    # Same SA, same project (subauth). Always allowed.
	    goto permokay
		if ($experiment->pid() eq $lease->pid() &&
		    $experiment->gid() eq $lease->gid());

	    #
	    # Okay, same pid (SA) but different group (sub authority).
	    # Must have a credential from the SA that says its okay.
	    #
	    my $manager_urn = $lease->GetAttribute("manager_urn");
	    next
		if (!defined($manager_urn));
	    my ($manager_domain) = GeniHRN::Parse($manager_urn);
	    
	    foreach my $credential (@credentials) {
		next
		    if (!$credential->HasActualPrivilege("blockstores"));

		my ($domain, undef, $id) =
		    GeniHRN::Parse($credential->target_urn());

		goto permokay
		    if ($domain eq $manager_domain &&
			$id eq $lease->lease_id());

	    }
	    # If we get here, its not allowed.
	    $message = "No permission to use dataset $dataset_id";
	    $errorcode = GENIRESPONSE_FORBIDDEN;
	    goto bad;

	  permokay:
	    #
	    # Only one read-write user at a time.
	    #
	    if ($readonly && $lease->InUseReadWrite()) {
		$message = "Dataset $dataset_id is already in use RW";
		goto bad;
	    }
	    # We need some stuff from the blockstore to fill out the
	    # virt tables below.
	    my $blockstore = Blockstore->LookupByLease($lease->lease_idx());
	    if (!defined($blockstore)) {
		$message = "Could not get blockstore for dataset $dataset_id";
		goto bad;
	    }
	    $btype = $lease->type();
	    $size  = $blockstore->total_size();

	    push(@attributes, ["lease", $lease->lease_idx(), 1]);
	}
	else {
	    $size = GeniXML::GetText("size", $blockref);
	
	    if (!defined($size)) {
		$message = "Missing blockstore size for $bsname";
		goto bad;
	    }
	    $size = Blockstore::ConvertToMebi($size);
	    if ($size < 0) {
		$message = "Illegal blockstore size for $bsname";
		goto bad;
	    }
	}
    }
    else {
	#
	# Might be a XEN VM. The easiest thing to do is add a XEN_EXTRAFS
	# argument, which will be ignored if not a XEN VM. There might be
	# a xen settings section in the node, but we will ignore it and
	# just delete/insert a properly sized attribute.
	#
	my $attrkey;
	my $attrvalue;
	my $row;

	if (0) {
	    $attrkey   = "XEN_EXTRAFS";
	    $attrvalue = ceil($size / 1024);

	    $row = $virtexperiment->Find("virt_node_attributes",
					 $nodename, $attrkey);
	}
	else {
	    $attrkey   = "XEN_EXTRADISKS";
	    $attrvalue = "$bsname:" . ceil($size / 1024) . "GB";

	    $row = $virtexperiment->Find("virt_node_attributes",
					 $nodename, $attrkey);
	    if (defined($row)) {
		$attrvalue  = $row->attrvalue() . "," . $attrvalue;
	    }
	}
	if (defined($row)) {
	    $row->Delete($VirtExperiment::STORE_FLAGS_DEBUG);
	}
	$virtexperiment->NewTableRow("virt_node_attributes",
				     {"vname"     => $nodename,
				      "attrkey"   => $attrkey,
				      "attrvalue" => $attrvalue});
    }
    $virtexperiment->NewTableRow("virt_blockstores",
				 {"vname"     => $bsname,
				  "type"      => $btype,
				  "size"      => $size,
				  "fixed"     => $fixed,
				 });
    foreach my $aref (@attributes) {
	my ($aname, $value, $isdesire) = @{$aref};
	$virtexperiment->NewTableRow("virt_blockstore_attributes",
				     {"vname"     => $bsname,
				      "attrkey"   => $aname,
				      "attrvalue" => $value,
				      "isdesire"  => $isdesire,
				     });
    }
    return 0;

  bad:
    return GeniResponse->Create($errorcode, undef, $message);
}

sub AnnotateAddressPools($$)
{
    my ($manifest, $experiment) = @_;
    my @address_pools = GeniXML::FindNodesNS('n:routable_pool', $manifest, $GeniXML::EMULAB_NS)->get_nodelist();
    foreach my $pool (@address_pools) {
	# Ignore pools from other CMs
	my $cmurn = GetText("component_manager_id", $pool);
	if (! defined($cmurn) ||
	    $cmurn eq $ENV{'MYURN'}) {
	    # Clear out any address that might have been there
	    # before. Mostly so we don't do something dumb if they
	    # re-submit a manifest.
	    my @old_addresses = GeniXML::FindNodesNS('n:ipv4', $pool, $GeniXML::EMULAB_NS)->get_nodelist();
	    foreach my $old_address (@old_addresses) {
		$pool->removeChild($old_address);
	    };
	    # Bind to this AM
	    GeniXML::SetText("component_manager_id",
			     $pool, $ENV{'MYURN'});
	    # Fill actual address assignment for all pools
	    my $pool_id = GetText("client_id", $pool);
	    my $addressList = $experiment->LookupAddressPools($pool_id);
	    foreach my $address (@{ $addressList }) {
		my $newnode = GeniXML::AddElement('ipv4', $pool);
		GeniXML::SetText("address", $newnode, $address->{"ip"});
		GeniXML::SetText("netmask", $newnode, $address->{"netmask"});
	    }
	}
    }
}

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