GeniCM.pm.in

#!/usr/bin/perl -wT
#
# Copyright (c) 2008-2017 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 ceil);
use Time::Local;
use Compress::Zlib;
use File::Temp qw(tempfile tmpnam);
use MIME::Base64;
use Digest::SHA1 qw(sha1_hex);
use POSIX ":sys_wait_h";
use Errno qw(:POSIX);

# 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";
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 $RFLINKS	   = "$TB/bin/rflinks";
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 OSImage;
    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);

    #
    # Watch for sites that do not support openflow, we want to fail early.
    #
    my $no_openflow = 0;
    my $ignore_openflow = 0;
    if (!GetSiteVar('general/no_openflow', \$no_openflow)){
	# Cannot get the value, say no.
	$no_openflow = 1;
    }
    if ($no_openflow =~ /ignore/) {
	$no_openflow = 1;
	$ignore_openflow = 1;
    }

    # 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 > 0 && !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;
    }
    #
    # Mark the expires slot in the experiment, for admission control
    # during the mapper run. 
    #
    # Convert to a localtime.
    #
    if (defined($expires)) {
	$expires = eval { timegm(strptime($expires)); };
	if ($@ || !defined($expires)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Could not parse expiration");
	    goto bad;
	}
    }
    else {
	$expires = $slice->expires();
    }
    if ($slice_experiment->SetExpiration($expires)) {
	$response = GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					 "set experiment expiration");
	print STDERR "Could not set experiment expiration\n";
	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);

    #
    # Allow user to control the multiplex factor. Note that ptopgen
    # will not allow the mfactor to be more then what we set as the
    # max for the node, but in general we set it low here. Also note
    # that to support Emulab Classic NS file conversion, zero means to
    # not change it.
    #
    my $mfactor = GeniXML::MultiplexFactor($rspec);
    if (defined($mfactor)) {
	if ($mfactor != 0) {
	    $virtexperiment->multiplex_factor($mfactor);
	}
    }
    else {
	# Odd geni default dating back to the beginning of time.
	$virtexperiment->multiplex_factor(10);
    }
    #
    # The packing strategy is sorta independent; the user can specify either
    # pack or balance (load balance).
    #
    my $packing_option = GeniXML::PackingStrategy($rspec);

    #
    # User can turn off routing.
    #
    my $routertype = GeniXML::RoutingStyle($rspec);
    if (!defined($routertype)) {
	$routertype = "static-ddijk";
    }
    elsif ($routertype eq "static") {
	$routertype = "static-ddijk";
    }
    elsif ($routertype ne "none") {
	$response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					 "Bad routing style: $routertype");
	goto bad;
    }
    
    #
    # User can set the delay image. 
    #
    if (defined(GeniXML::DelayImage($rspec))) {
	my $delayurn = GeniXML::DelayImage($rspec);
	
	if (!GeniHRN::IsValid($delayurn)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Invalid URN: $delayurn");
	    goto bad;
	}
	my $hrn = GeniHRN->new($delayurn);
	my (undef,$ospid,$os,$vers) = $hrn->ParseImage();
	if ($hrn->type() ne "image" || !defined($ospid) || !defined($os)) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Malformed image URN: $delayurn");
	    goto bad;
	}
	my $delayname = $os;
	$delayname = "${ospid}/" . $delayname
	    if (defined($ospid));
	$delayname .= ":${vers}"
	    if (defined($vers));
	
	$virtexperiment->delay_osname($delayname);
    }

    #
    # 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"});
    $virtexperiment->NewTableRow("virt_agents",
				 {"vnode"      => "*",
				  "vname"      => "linktest",
				  "objecttype" => "7"});

    #
    # 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_BADARGS, 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);
	}
    }
    #
    # Note that we set the mounts to "genidefault" when we create the
    # container experiment. So this overrides.
    #
    if ($PROTOGENI_NONFSMOUNTS) {
	$virtexperiment->nonfsmounts(1);
	# This is the new way of doing things.
	$virtexperiment->nfsmounts("none");
    }
    elsif (GeniXML::FromEmulabPortal($rspec) && $PROTOGENI_LOCALUSER) {
	#
	# By not setting, we get standard emulab mounts which include
	# /users. Not sure if I want to explictly set this.
	#
	# But we do not let anyone do this, at the moment only the local
	# SA can do that, which means the authority that contacted us
	# must be our SA. Not even users from our SA can specify this.
	#
	my $hrn = GeniHRN->new($ENV{"GENIURN"});
	if (defined($hrn) &&
	    $hrn->domain() eq $OURDOMAIN && $hrn->IsSA()) {
	    $virtexperiment->nfsmounts("emulabdefault");
	}
    }

    #
    # 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 = ();
    my %allnodes = ();
    # Extra nodes (like XEN vhosts).
    my %internal_nodemap  = ();
    # For stitching, keep track of external nodes and links.
    my %external_nodemap  = ();
    my %external_linkmap  = ();
    my %external_vportmap = ();
    my %external_lanrefs  = ();
    my $routable_ip_count = 0;
    my $sync_server = ($isupdate ? $slice_experiment->sync_server() : undef);

    # Always do this to avoid buildup.
    $slice_experiment->ClearBackupState();

    #
    # Find all the node client ids, so we can support binding VMs to other
    # nodes in the topology. We could enforce that the rspec has to put
    # those nodes first, but that would be annoying to users. And me.
    #
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->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);

	# Might as well do a duplicate check while we are here.
	if (exists($allnodes{lc($node_nickname)})) {
	    $response = GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
					     "Duplicate node $node_nickname");
	    goto bad;
	}
	$allnodes{lc($node_nickname)} = 1;
    }
    
    #
    # 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);

    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 $instantiate_on= GeniXML::GetInstantiateOn($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;
	
	# 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 = OSImage->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.
		    #
		    if (! ($osinfo->global() ||
			   $osinfo->pid() eq $slice_experiment->pid())) {
			if ($PROTOGENI_LOCALUSER && $user->IsLocal()) {
			    my $image = OSImage->Lookup($ospid,$os,$vers);
			    if (!defined($image)) {
				$response =
				    GeniResponse->Create(GENIRESPONSE_BADARGS,
							 undef,
							 "No image: $dname");
				goto bad;
			    }
			    goto noperm
				if (!$image->AccessCheck($user->emulab_user(),
							 TB_IMAGEID_READINFO));
			}
			else {
			  noperm:
			    $response =
				GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				 "Insufficient permission to use $dname");
			    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 = "UBUNTU14-64-STD";
			    }
			}
			# If not set, we will pick up the default_image below.