create_instance.in

#!/usr/bin/perl -w
#
# 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.
# 
# }}}
#
use strict;
use English;
use Getopt::Long;
use XML::Simple;
use File::Temp qw(tempfile :mktemp tmpnam :POSIX);
use Data::Dumper;
use Cwd qw(realpath);

#
# Create a quick VM.
# 
sub usage()
{
    print "Usage: quickvm [-u uuid] [--site site:1=aggregate ...] <xmlfile>\n";
    exit(1);
}
my @optlist = ('d', 'v', 'u=s', 'a=s', 'S', 'k=s', 'i');
my $debug   = 0;
my $verbose = 1;
my $ignorefailures = 0;
my $xmlfile;
my $webtask;
my $webtask_id;
my $localuser  = 0;
my $usestitcher= 0;
my $quickuuid;
my $this_user;
my $xmlparse;
my $instance;
my $privkeyfile;
my $slice;
my $sitemap;
my $usetracker = 0;
my $maxduration = 3; # Hours. For guests. Need to make this a site variable.
my @aggregate_urns = ();

# Protos
sub fatal($);
sub UserError($);
sub SnapShot($$$);
sub CreateDatasetCreds($$$$$);
sub CreateSlivers();
sub RunStitcher();

#
# Configure variables
#
my $TB		  = "@prefix@";
my $TBOPS         = "@TBOPSEMAIL@";
my $TBLOGS        = "@TBLOGSEMAIL@";
my $OURDOMAIN     = "@OURDOMAIN@";
my $MAINSITE      = @TBMAINSITE@;
my $PGENIDOMAIN   = "@PROTOGENI_DOMAIN@";
my $PROTOGENI_URL = "@PROTOGENI_URL@";
my $SACERT	  = "$TB/etc/genisa.pem";
my $CMCERT	  = "$TB/etc/genicm.pem";
my $SSHKEYGEN     = "/usr/bin/ssh-keygen";
my $SSHSETUP      = "$TB/sbin/aptssh-setup";
my $ADDPUBKEY     = "$TB/sbin/addpubkey";
my $UPDATEGENIUSER= "$TB/sbin/protogeni/updategeniuser";
my $STITCHER      = "$TB/gcf/src/stitcher.py";
my $OPENSSL       = "/usr/bin/openssl";
my $MANAGEINSTANCE= "$TB/bin/manage_instance";
my $MANAGEDATASET = "$TB/bin/manage_dataset";
my $MANAGEGITREPO = "$TB/bin/manage_gitrepo";
my $DEFAULT_URN   = "urn:publicid:IDN+$OURDOMAIN+authority+cm";
my $GUEST_URN     = "urn:publicid:IDN+apt.emulab.net+authority+cm";
my $PROTOGENI_LOCALUSER= @PROTOGENI_LOCALUSER@;
my $default_aggregate_urn = $DEFAULT_URN;

# un-taint path
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/site/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

#
# Turn off line buffering on output
#
$| = 1;

# Load the Testbed support stuff.
use lib "@prefix@/lib";
use EmulabConstants;
use libtestbed;
use libaudit;
use APT_Profile;
use APT_Instance;
use APT_Geni;
use APT_Dataset;
use APT_Aggregate;
use Experiment;
use User;
use Project;
use Group;
use Image;
use emutil;
use libEmulab;
use GeniDB;
use GeniUser;
use GeniCertificate;
use GeniCredential;
use GeniSlice;
use GeniAuthority;
use GeniHRN;
use Genixmlrpc;
use GeniResponse;
use GeniXML;
use WebTask;
use Logfile;
use EmulabFeatures;

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
Getopt::Long::Configure("no_ignore_case");
my %options = ();
if (! GetOptions(\%options, @optlist, "site=s%" => \$sitemap)) {
    usage();
}
if (defined($options{"a"})) {
    $default_aggregate_urn = $options{"a"};
}
if (defined($options{"k"})) {
    $privkeyfile = $options{"k"};
}
if (defined($options{"d"})) {
    $debug = 1;
}
if (defined($options{"i"})) {
    $ignorefailures = 1;
}
if (defined($options{"v"})) {
    $verbose = 1;
}
if (defined($options{"S"})) {
    $usestitcher = 1;
}
if (defined($options{"u"})) {
    $quickuuid = $options{"u"};
}
if (@ARGV < 1) {
    usage();
}
$xmlfile = shift(@ARGV);

#
# Check the filename when invoked from the web interface; must be a
# file in /tmp.
#
if (getpwuid($UID) ne "nobody") {
    $this_user = User->ThisUser();

    if (! defined($this_user)) {
	fatal("You ($UID) do not exist!");
    }
    $localuser = 1;
    $maxduration = 16; # Hours.
}
if (!defined($this_user) || !$this_user->IsAdmin()) {
    if ($xmlfile =~ /^([-\w\.\/]+)$/) {
	$xmlfile = $1;
    }
    else {
	fatal("Bad data in pathname: $xmlfile");
    }

    # Use realpath to resolve any symlinks.
    my $translated = realpath($xmlfile);
    if ($translated =~ /^(\/tmp\/[-\w\.\/]+)$/) {
	$xmlfile = $1;
    }
    else {
	fatal("Bad data in translated pathname: $xmlfile");
    }
}

# Email record.
if (! $debug) {
    my $opts = LIBAUDIT_LOGTBLOGS()|LIBAUDIT_LOGONLY();
    AuditStart(0, undef, $opts);
    #
    # Once we determine the project, we can add the appropriate log CC
    #
}

# Connect to the SA DB.
DBConnect(GENISA_DBNAME());

#
# Load the SA cert to act as caller context.
#
my $sa_certificate = GeniCertificate->LoadFromFile($SACERT);
if (!defined($sa_certificate)) {
    fatal("Could not load certificate from $SACERT\n");
}
my $sa_authority = GeniAuthority->Lookup($sa_certificate->urn());
if (!defined($sa_authority)) {
    fatal("Could not load SA authority object");
}
# Guest users default to the APT cluster on the Mothership.
if ($MAINSITE && !$localuser) {
    $default_aggregate_urn = $GUEST_URN;
}

#
# We use the normal XMLRPC route, so need a context.
#
my $context = Genixmlrpc->Context($sa_certificate);
if (!defined($context)) {
    fatal("Could not create context to talk to CM");
}
Genixmlrpc->SetContext($context);

#
# Must wrap the parser in eval since it exits on error.
#
$xmlparse = eval { XMLin($xmlfile,
			 VarAttr => 'name',
			 ContentKey => '-content',
			 SuppressEmpty => undef); };
fatal($@)
    if ($@);

#
# Make sure all the required arguments were provided.
#
foreach my $key ("username", "email", "profile", "portal", "duration") {
    fatal("Missing required attribute '$key'")
	if (! (exists($xmlparse->{'attribute'}->{"$key"}) &&
	       defined($xmlparse->{'attribute'}->{"$key"}) &&
	       $xmlparse->{'attribute'}->{"$key"} ne ""));
}

#
# Gather up args and sanity check.
#
my ($value, $user_urn, $user_uid, $user_hrn, $user_email, $project, $pid,
    $gid, $group, $sshkey, $profile, $profileid, $version, $rspecstr, $errmsg,
    $userslice_id, $portal, $script, $reporef, $repohash, $duration);

# This is used internally to determine which portal was used.
$portal = $xmlparse->{'attribute'}->{"portal"}->{'value'};

# User specified duration.
$duration = $xmlparse->{'attribute'}->{"duration"}->{'value'};
if ($duration !~ /^\d+$/) {
    fatal("Duration is not an integer");
}
if ($duration < 1 || $duration > $maxduration) {
    UserError("Duration must be at least 1 hour but ".
	      "not more then $maxduration hour(s)");
}

#
# Username and email has to be acceptable to Emulab user system.
#
$value = $xmlparse->{'attribute'}->{"username"}->{'value'};
if (! TBcheck_dbslot($value, "users", "uid",
		     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
    fatal("Illegal username: $value - " . TBFieldErrorString());
}
$user_uid = $value;
$user_urn = GeniHRN::Generate("$OURDOMAIN", "user", $user_uid);
$user_hrn = "${PGENIDOMAIN}.${user_uid}";

$value = $xmlparse->{'attribute'}->{"email"}->{'value'};
if (! TBcheck_dbslot($value, "users", "usr_email",
		     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
    fatal("Illegal email address: $value");
}
$user_email = $value;

#
# The instance name is optional, we will make one up if not supplied.
#
if (exists($xmlparse->{'attribute'}->{"instance_name"}) &&
    $xmlparse->{'attribute'}->{"instance_name"}->{'value'} ne "") {
    $value = $xmlparse->{'attribute'}->{"instance_name"}->{'value'};
    if (! TBcheck_dbslot($value, "experiments", "eid",
			 TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	fatal("Illegal instance name: $value");
    }
    $userslice_id = $value;
}

#
# Profile.
#
# This is a safe lookup.
$value = $xmlparse->{'attribute'}->{"profile"}->{'value'};
$profile = APT_Profile->Lookup($value);
if (!defined($profile)) {
    fatal("No such profile: $value");
}
$profileid = $profile->profileid();
$version   = $profile->version();

#
# Optional rspec, as for a Parameterized Profile or a repo-based profile.
#
if (exists($xmlparse->{'attribute'}->{"rspec"})) {
    $rspecstr  = $xmlparse->{'attribute'}->{"rspec"}->{'value'};
}
else {
    $rspecstr  = $profile->CheckFirewall(!$localuser);
}
#
# Optional rspec and/or script, as for a repo-based profile.
#
if ($profile->repourl()) {
    if (exists($xmlparse->{'attribute'}->{"script"})) {
	$script = $xmlparse->{'attribute'}->{"script"}->{'value'};	

	if (! TBcheck_dbslot($script, "apt_profiles", "script",
			     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    fatal("Illegal script for repo-based profile");
	}
	if (!exists($xmlparse->{'attribute'}->{"reporef"})) {
	    fatal("Missing refspec for repository");
	}
    }
    if (exists($xmlparse->{'attribute'}->{"reporef"})) {
	if (!exists($xmlparse->{'attribute'}->{"repohash"})) {
	    fatal("Missing hash for repository");
	}
	$reporef  = $xmlparse->{'attribute'}->{"reporef"}->{'value'};
	$repohash = $xmlparse->{'attribute'}->{"repohash"}->{'value'};

	if (! TBcheck_dbslot($repohash, "apt_profiles", "repohash",
			     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    fatal("Illegal repository hash");
	}
	if (! TBcheck_dbslot($reporef, "default", "tinytext",
			     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    fatal("Illegal repository refspec");
	}
    }
    else {
	# Otherwise we are instantiating whatever the profile itself references.
	$reporef  = "refs/heads/master";
	$repohash = $profile->repohash();
    }
}

#
# Update rspec with site aggregate urns.
#
# SetSites will tell us if we must use stitcher.
#
my $needstitcher = 0;
my $tmp = APT_Profile::SetSites(\$rspecstr, $sitemap, $default_aggregate_urn,
				\@aggregate_urns, \$needstitcher, \$errmsg);
if ($tmp) {
    ($tmp < 0 ? fatal($errmsg) : UserError($errmsg));
}
#
# Yep, this can happen when users do not put any nodes in their rspec.
#
if (!@aggregate_urns) {
    UserError("There are no nodes in your experiment, syntax error?");
}

# but do not override command line force.
$usestitcher = 1 if ($needstitcher);

#
# Look for datasets; need to verify that the datasets being referenced
# actually exists, in so far as we can check. We check permissions
# below when we generate the credentials.
#
$errmsg = "Bad dataset";
if (APT_Profile::CheckDatasets($rspecstr, \$errmsg)) {
    UserError($errmsg);
}

#
# Use ssh-keygen to see if the key is valid and convertable. We first
# try to get the fingerprint, which will tells us if its already in
# openssh format. If not, try to convert it.
#
if (exists($xmlparse->{'attribute'}->{"sshkey"}) &&
    defined($xmlparse->{'attribute'}->{"sshkey"}) &&
    $xmlparse->{'attribute'}->{"sshkey"} ne "") {
    $sshkey = $xmlparse->{'attribute'}->{"sshkey"}->{'value'};
    my ($fh, $keyfile) = tempfile(UNLINK => 0);
    print $fh $sshkey;

    if (system("$SSHKEYGEN -l -f $keyfile >/dev/null 2>/dev/null")) {
	if (! open(KEYGEN, "$SSHKEYGEN -i -f $keyfile 2>/dev/null |")) {
	    fatal("Could not start ssh-keygen");
	}
	$sshkey = <KEYGEN>;
	if (!close(KEYGEN)) {
	    UserError("Could not parse ssh key!");
	}
    }
    close($fh);
    unlink($keyfile);
}
chomp($sshkey)
    if (defined($sshkey));

#
# See if the GeniUser exists. Create if not, but that means we
# have to create an ssl certificate (which the user will never see)
# so that we can operate on behalf of the user (via speaksfor).
#
# Note that we want to check for the user local account ahead of
# SA account, to bypass their guest account that might still be
# in the table.
#
my $geniuser;

if ($localuser) {
    my $emulab_user = User->Lookup($user_uid);
    
    #
    # Hmm, users with real accounts who never used Geni, but now want
    # to use APT/Cloud, have no encrypted SSL certificate. Rather then
    # force them through the web ui (and have to explain it), create one
    # for them using a random passphrase. The user will not know the
    # passphrase, but for most users it will not matter.
    #
    # This is also going to catch expired certificates, we will regenerate
    # them using the existing passphrase.
    #
    if ($emulab_user->HasValidEncryptedCert() == 0 &&
	$emulab_user->GenEncryptedCert()) {
	fatal("Could not (re)generate encrypted certificate");
    }
    # Now this will work; without a certificate, above line would fail.
    if (defined($emulab_user)) {
	$geniuser = GeniUser::LocalUser->Create($emulab_user);
    }
}
else {
    $geniuser = GeniUser->Lookup($user_urn);

    #
    # In Utah, check for alternate SA
    #
    if (!defined($geniuser) && $MAINSITE) {
	foreach my $urn (@aggregate_urns) {
	    if ($urn ne $GUEST_URN) {
		UserError("Guests are not allowed to use cluster: $urn");
	    }
	}
	$user_urn = GeniHRN::Generate("aptlab.net", "user", $user_uid);
	$user_hrn = "aptlab.${user_uid}";
	$geniuser = GeniUser->LookupGuestOnly($user_urn);
    }
}
if (!defined($geniuser)) {
    if ($localuser) {
	fatal("Could not lookup local user $user_urn");
    }
    
    #
    # Do not allow overlap with local users.
    #
    if (User->Lookup($user_uid)) {
	fatal("User $user_uid exists in the local user table");
    }

    print "Geni user does not exist; creating one ...\n"
	if ($debug);

    #
    # Want to remember the auth token we emailed for later.
    #
    my $auth_token = $xmlparse->{'attribute'}->{"auth_token"}->{'value'};
    if ($auth_token !~ /^[\w]+$/) {
	fatal("Bad auth token: $auth_token");
    }
    my $blob = {"urn"      => $user_urn,
		"hrn"      => $user_hrn,
		"email"    => $user_email,
		"showuuid" => 1};
    if ($MAINSITE) {
	$blob->{'useaptca'} = 1;
    }
    my $certificate = GeniCertificate->Create($blob);
    fatal("Could not create certificate")
	if (!defined($certificate));

    $geniuser = GeniUser->Create($certificate, $sa_authority);
    fatal("Could not create new geni user")
	if (!defined($geniuser));

    $geniuser->SetAuthToken($auth_token);

    #
    # Setup browser ssh.
    #
    system("$SSHSETUP " . $geniuser->uuid());
    fatal("Could not create ssh key pair")
	if ($?);
}
my $user_uuid = $geniuser->uuid();
# So we know this user has dome something lately.
$geniuser->BumpActivity();

if ($localuser) {
    my $emulab_user = $geniuser->emulab_user();
    if ($emulab_user->IsNonLocal()) {
	#
	# A user created from a Geni certificate via geni-login. We
	# asked for the current ssh keys from the MA when they logged
	# in, but we ask again to make sure have the latest keys.
	#
	system("$UPDATEGENIUSER -s " . $emulab_user->uid());
	if (0) {
	    fatal("Could not update ssh keys for nonlocal user");
	}
	#
	# Check project membership, must be a member of at least one
	# valid project at the GPO portal.
	#
	system("$UPDATEGENIUSER -p " . $emulab_user->uid());
	if ($?) {
	    UserError("Could not get your project membership from your ".
		      "member authority. It is probably offline, please try ".
		      "again later.");
	}
	# Nonlocal users get the holding project can now join/create
	# real projects, so we get the pid passed in.
    }
    elsif (defined($sshkey) && !$emulab_user->LookupSSHKey($sshkey)) {
	#
	# XXX This is deprecated; we no longer show the ssh box to
	#     real users. Remove when we are satisfied with new
	#     ssh key management page.
	#
	
	#
	# A local user. We mark keys that come through this path
	# with the isaptkey flag (-a to addpubkey) so that we know
	# which key in the DB it is. The reason for this is that the
	# user might be a classic emulab user, but is now using the
	# APT/Cloud UI. The key provided in the web interface will
	# replace this key.
	#
	# XXX This is in flux, we now allow APT users to manage all
	# their keys via the web interface.
	#
	my ($fh, $keyfile) = tempfile(UNLINK => 0);
	print $fh $sshkey;

	if (system("$ADDPUBKEY -a -u $user_uid -f $keyfile")) {
	    fatal("Could not add new ssh pubkey");
	}
	close($fh);
	unlink($keyfile);
    }
    #
    # Hmm, users with real accounts who never used Geni, but now want
    # to use APT/Cloud, have no encrypted SSL certificate. Rather then
    # force them through the web ui (and have to explain it), create one
    # for them using a random passphrase. The user will not know the
    # passphrase, but for most users it will not matter.
    #
    # This is also going to catch expired certificates, we will regenerate
    # them using the existing passphrase.
    #
    if ($emulab_user->HasValidEncryptedCert() == 0 &&
	$emulab_user->GenEncryptedCert()) {
	fatal("Could not (re)generate encrypted certificate");
    }

    # Local users are required to select a project.
    if (! exists($xmlparse->{'attribute'}->{"pid"})) {
	fatal("No project provided for new instance");
    }
    $project = Project->Lookup($xmlparse->{'attribute'}->{"pid"}->{"value"});
    if (!defined($project)) {
	fatal("Project provided does not exist");
    }
    if (!$project->AccessCheck($emulab_user, TB_PROJECT_CREATEEXPT)) {
	fatal("No permission to create experiments in project ".
	      $project->pid());
    }
    $pid = $project->pid();

    # Option subgroup.
    if (exists($xmlparse->{'attribute'}->{"gid"}) &&
	$xmlparse->{'attribute'}->{"gid"}->{"value"} ne "" &&
	$xmlparse->{'attribute'}->{"gid"}->{"value"} ne $pid) {
	my $val = $xmlparse->{'attribute'}->{"gid"}->{"value"};
	$group = $project->LookupGroup($val);
	if (!defined($group)) {
	    fatal("Group $val does not exist in project $pid");
	}
    }
    else {
	$group = $project->GetProjectGroup();
    }
    $gid = $group->gid();

    # Use of the Image Tracker is a Portal directive at the moment.
    $usetracker = 1
	if (GetSiteVar("protogeni/use_imagetracker") &&	
	    EmulabFeatures->FeatureEnabled("APT_UseImageTracker",
					   $emulab_user, $project));
}
elsif (!$localuser) {
    if (defined($sshkey)) {    #
	# Guest user; remember key. For now we accept only one key. We store
	# it simply so we can display it again for the user in the web
	# interface. We allow key reuse for existing users, see above.
	#
	$geniuser->DeleteKeys();
	$geniuser->AddKey($sshkey);
    }
    # Guest users get a holding project.
    $pid = $APT_HOLDINGPROJECT;
    $project = Project->Lookup($pid);
    $group = $project->GetProjectGroup();
    $gid = $group->gid();
    if (!defined($project)) {
	fatal("Project $pid does not exist");
    }
}
if (defined($profile->repourl())) {
    #
    # Make sure the repo is still accessible.
    #
    my $check = emutil::ExecQuiet("$MANAGEGITREPO check ".
				  "'" . $profile->repourl() . "'");
    if ($?) {
	UserError($check);
    }
    $tmp = APT_Profile::SetRepo(\$rspecstr, $profile->repourl(),
				$reporef, $repohash, $geniuser, \$errmsg);
    if ($tmp) {
	($tmp < 0 ? fatal($errmsg) : UserError($errmsg));
    }
}

#
# Now we know where to send to logs.
#
if (!$debug) {
    AddAuditInfo("cc", $project->LogsEmailAddress());
    if ($MAINSITE && $project->isEmulab()) {
	# Mostly people use the Cloudlab UI.
	AddAuditInfo("cc", "cloudlab-logs\@cloudlab.us");
    }
}

# Check for expired certs and speaksfor.
my $retval = APT_Geni::VerifyCredentials($geniuser, \$errmsg);
if ($retval) {
    ($retval < 0 ? fatal($errmsg) : UserError($errmsg));
}

# Generate the extra credentials that tells the backend this experiment
# can access the datasets.
my @dataset_credentials = ();
if (defined($profile)) {
    my $retval = CreateDatasetCreds($rspecstr, $project, $geniuser, 
				    \$errmsg, \@dataset_credentials);
    if ($retval) {
	($retval < 0 ? fatal($errmsg) : UserError($errmsg));
    }
}

#
#
# Now generate a slice registration and credential
#
my $safe_uid    = $user_uid; $safe_uid =~ s/_/-/;
my $slice_id    = (defined($userslice_id) ? $userslice_id :
		   $safe_uid . "-QV" . TBGetUniqueIndex('next_quickvm', 1));
my $slice_auth  = ($pid eq $gid ? $pid : "${pid}:${gid}");
my $slice_urn   = GeniHRN::Generate("${OURDOMAIN}:${slice_auth}",
				    "slice", $slice_id);
my $slice_hrn   = "${PGENIDOMAIN}.${pid}.${slice_id}";
my $SERVER_NAME = (exists($ENV{"SERVER_NAME"}) ? $ENV{"SERVER_NAME"} : "");

#
# Make sure slice is unique. Probably retry here at some point. 
#
if (GeniSlice->Lookup($slice_hrn) || GeniSlice->Lookup($slice_urn) ||
    ($PROTOGENI_LOCALUSER &&
     (grep {$_ eq $DEFAULT_URN} @aggregate_urns) &&
     Experiment->Lookup($project->pid(), $userslice_id))) {
    if (defined($userslice_id)) {
	UserError("Experiment name already in use, please use another. If you ".
		  "just terminated an experiment with this name, it takes a ".
		  "minute or two for the name to become available again.");
    }
    else {
	fatal("Could not form a unique slice name");
    }
}

#
# Generate a certificate for this new slice.
#
my $slice_certificate =
    GeniCertificate->Create({'urn'  => $slice_urn,
			     'hrn'  => $slice_hrn,
			     'showuuid' => 1,
			     'email'=> $user_email});

if (!defined($slice_certificate)) {
    fatal("Could not generate certificate for $slice_urn");
}
# Slice is created as locked.
$slice = GeniSlice->Create($slice_certificate,
			   $geniuser, $sa_authority, undef, 1);
if (!defined($slice)) {
    $slice_certificate->Delete();
    fatal("Could not create new slice object for $slice_urn");
}
# These get quick expirations, unless it is a real user.
if ($slice->SetExpiration(time() + ($duration * 3600)) != 0) {
    fatal("Could not set the slice expiration for $slice_urn");
}
my $slice_uuid = $slice->uuid();

#
# Generate a new ssl key/cert to be used to derive an ssh key pair
# or whatever else is needed. This is sent along as an option when the
# sliver is created (or provisioned, when stitching).
#
# This is going to be a real geni certificate, albeit a slice
# certificate in the alternate CA domain, that can be used at the
# "portal" XMLRPC interface. The key is unencrypted and put on the
# nodes, hence the alternate CA, and the XMLRPC server will not allow
# this certificate to do anything, except at the portal RPC server.
#
my $alt_urn = GeniHRN::Generate("aptlab.net:${slice_auth}", "slice", $slice_id);
my $alt_hrn = "aptlab.${pid}.${slice_id}";
my $alt_url = "$PROTOGENI_URL/portal";

my $altblob = {"urn"      => $alt_urn,
	       "hrn"      => $alt_hrn,
	       "url"      => $alt_url,
	       "uuid"     => $slice_uuid,
	       "email"    => $user_email,
	       "nostore"  => 1,
               "keyfile"  => $privkeyfile,
	       "useaptca" => 1,
	       "showuuid" => 1};
my $alt_certificate = GeniCertificate->Create($altblob);
fatal("Could not create alt certificate")
    if (!defined($alt_certificate));

#
# Encrypt blocks.
#
$tmp = APT_Profile::EncryptBlocks(\$rspecstr, $alt_certificate, \$errmsg);
if ($tmp) {
    ($tmp < 0 ? fatal($errmsg) : UserError($errmsg));
}
#
# Tell the CM to do normal NFS mounts if this is the "Emulab" portal
# making the request. The CM is of course free to ignore this.
#
# XXX Need to handle this differently if we use the stitcher.
#
if ($portal ne "emulab") {
    if (APT_Profile::ClearPortalTag(\$rspecstr, $errmsg)) {
        fatal($errmsg);
    }
}
elsif (APT_Profile::AddPortalTag(\$rspecstr, $portal, $errmsg)) {
    fatal($errmsg);
}

#
# Generate credentials we need.
#
my ($slice_credential, $speaksfor_credential) =
    APT_Geni::GenCredentials($slice, $geniuser, undef, 0);
if (! (defined($speaksfor_credential) &&
       defined($slice_credential))) {
    fatal("Could not generate credentials");
}

#
# Got this far, lets create a quickvm record.
#
my $quickvm_uuid = (defined($quickuuid) ? $quickuuid : NewUUID());
if (!defined($quickvm_uuid)) {
    fatal("Could not generate a new uuid");
}
my $blob = {'uuid'         => $quickvm_uuid,
	    'name'         => $slice_id,
	    'profile_id'   => $profileid,
	    'profile_version' => $version,
	    'slice_uuid'   => $slice_uuid,
	    'creator'      => $geniuser->uid(),
	    'creator_idx'  => $geniuser->idx(),
	    'creator_uuid' => $geniuser->uuid(),
	    'status'       => "created",
	    'servername'   => $SERVER_NAME,
	    'rspec'        => $rspecstr,
	    'cert'         => $alt_certificate->cert(),
	    'privkey'      => $alt_certificate->PrivKeyDelimited(),
};
if ($profile->repourl()) {
    if (defined($script)) {
	$blob->{"script"}  = $script;
    }
    $blob->{"repourl"}   = $profile->repourl();
    $blob->{"reporef"}   = $reporef;
    $blob->{"repohash"}  = $repohash;
}
if (defined($project)) {
    $blob->{"pid"}     = $project->pid();
    $blob->{"pid_idx"} = $project->pid_idx();
    $blob->{"gid"}     = $group->gid();
    $blob->{"gid_idx"} = $group->gid_idx();
}
#
# Create a webtask so that we can store additional information about
# the sliver while we wait.
#
$webtask = WebTask->Create($quickvm_uuid);
if (!defined($webtask)) {
    fatal("Could not create a webtask!");
}
$webtask_id = $webtask->task_id();
$webtask->AutoStore(1);
$blob->{"webtask_id"} = $webtask_id;

$errmsg = undef;
$instance = APT_Instance->Create($blob, \$errmsg);
if (!defined($instance)) {
    $webtask->Delete();
    fatal(defined($errmsg) ? $errmsg :
	  "Could not create instance record for $quickvm_uuid");
}

#
# Get the set of keys (accounts) that need to be sent along. We build
# them in CM format, but convert to AM format later if needed.
#
my $sshkeys;
if ($instance->GetSSHKeys(\$sshkeys) < 0 || !@{$sshkeys}) {
    $slice->Delete();
    $instance->Delete();
    fatal("Error constructing ssh key list");
}

# We use this list of references for ParRun below.
my @aggregate_list = ();
foreach my $aggregate_urn (@aggregate_urns) {
    my $aptaggregate = APT_Aggregate->Lookup($aggregate_urn);
    if (!defined($aptaggregate)) {
        UserError("$aggregate_urn is not a valid (known) aggregate");
    }
    # Check for disabled/adminonly aggregates.
    if ($aptaggregate->disabled()) {
        UserError("$aggregate_urn is currently offline, try again later");
    }
    if ($aptaggregate->adminonly() &&
        !(defined($this_user) && $this_user->IsAdmin())) {
        UserError("Only administrators may use $aggregate_urn");
    }
    my $authority = GeniAuthority->Lookup($aggregate_urn);
    if (!defined($authority)) {
	$authority = GeniAuthority->CreateFromRegistry("cm", $aggregate_urn);
	if (!defined($authority)) {    
	    fatal("Could not load CM authority object for $aggregate_urn");
	}
    }
    my $aggobj = $instance->AddAggregate($aggregate_urn);
    if (!defined($aggobj)) {
	fatal("Could not create aggregate object for $aggregate_urn");
    }
    $aggobj->_authority($authority);
    push(@aggregate_list, $aggobj);
}

# To keep stuff happy until multisite support finished.
$instance->Update({'aggregate_urn' => $aggregate_urns[0]});

print STDERR "\n";
print STDERR "User:    $user_urn\n";
print STDERR "Email:   $user_email" . (!$localuser ? " (guest)" : "") . "\n";
if (defined($profile)) {
    print STDERR "Profile: " . $profile->name() . ":${version}\n";
}
print STDERR "Slice:   $slice_urn\n";
print STDERR "Server:  $SERVER_NAME\n";
print STDERR "Cluster: ";
print STDERR join(",", map($_->aggregate_urn(), @aggregate_list))  . "\n";
print STDERR "\n";
print STDERR "$rspecstr\n";

#
# Exit and let caller poll for status.
#
if (!$debug) {
    libaudit::AuditPrefork();
    my $child = fork();
    if ($child) {
	# Parent exits but avoid libaudit email.
	exit(0);
    }
    # All of the logging magic happens in here.
    libaudit::AuditFork();
}
# Bind the process id.
$webtask->SetProcessID($PID);

if ($usestitcher) {
    my $rval = RunStitcher();
    if ($rval) {
	$slice->UnLock();
	$instance->SetStatus("failed");
	$instance->RecordError($rval,
			       (defined($webtask->output()) ?
				$webtask->output() : ""));
	$webtask->Exited($rval);
	exit($rval);
    }
}
else {
    my $rval = CreateSlivers();
    #
    # We do not want email for most mapping errors, so look at the
    # return code to see if we want to kill the log (user will see the
    # error in the web ui). 
    #
    if ($rval) {
	$instance->RecordError($rval,
			       (defined($webtask->output()) ?
				$webtask->output() : ""));
	if ($rval == GENIRESPONSE_BADARGS ||
	    $rval == GENIRESPONSE_INSUFFICIENT_NODES ||
	    $rval == GENIRESPONSE_INSUFFICIENT_MEMORY ||
	    $rval == GENIRESPONSE_INSUFFICIENT_BANDWIDTH ||
	    $rval == GENIRESPONSE_NO_MAPPING) {
	    AuditAbort()
		if (!$debug);
	}
	$webtask->Exited($rval);
	exit($rval);
    }
}
$instance->SetStatus("provisioned");
$instance->ComputeNodeCounts();

#
# Now wait for the sliver to be ready, which means polling.
#
# Shorten default timeout.
#
Genixmlrpc->SetTimeout(60);

#
# Okay, fire off the waits for each aggregate
#
my @return_codes = ();
if (ParRun({"maxwaittime" => 99999, "maxchildren" => scalar(@aggregate_list)},
	    \@return_codes,
	    \&APT_Instance::Aggregate::WaitForSliver, @aggregate_list)) {
    #
    # The parent caught a signal. Leave things intact so that we can
    # kill things cleanly later.
    #
    $slice->UnLock();
    print STDERR "Internal error in WaitForSlivers\n";
    $webtask->output("Internal error in WaitForSlivers");
    $instance->SetStatus("failed");
    $webtask->Exited(1);
    exit(-1);
}
print "$slice_urn\n";

#
# If we were canceled, then none of the stuff below matters, we
# are going to do a terminate.
#
if ($instance->IsCanceled()) {
    $slice->UnLock();

    #
    # If someone gets the lock, this will fail. But the apt daemon will
    # see the canceled flag too and fire off a termination. 
    #
    system("$MANAGEINSTANCE -t $webtask_id terminate $quickvm_uuid");
    exit(0);
}

# Count up nodes running a startup service.
my $startuprunning = 0;

#
# Check the exit codes; any failure is a total failure (for now).
#
my $failed = 0;
foreach my $aggobj (@aggregate_list) {
    my $code = shift(@return_codes);

    # Updated in a forked child, must refresh. 
    $aggobj->Refresh();
    print $aggobj->aggregate_urn() . "\n";
    if ($code) {
	$failed++;
	print "WaitforSliver Failure!\n";
	if (defined($aggobj->webtask()->output())) {
	    $webtask->output($aggobj->webtask()->output());
	    $webtask->Exited($aggobj->webtask()->exitcode());
	    print $aggobj->webtask()->output() . "\n";
	}
	else {
	    $webtask->output("WaitforSliver Failure at " .
			     $aggobj->aggregate_urn());
	    $webtask->Exited(1);
	}
	# Promote the log up to the instance so that so its easy to find.
	$instance->SetPublicURL($aggobj->public_url())
	    if (defined($aggobj->public_url()));
    }
    else {
	my $statusblob = $aggobj->webtask()->sliverstatus();

	print Dumper($statusblob);

	foreach my $details (values(%{ $statusblob })) {
	    # Startup command is still running.
	    $startuprunning++
		if (exists($details->{'execute_state'}) &&
		    $details->{'execute_state'} ne "exited");
	}
    }
    if (defined($aggobj->public_url())) {
	print $aggobj->public_url() . "\n";
    }
    print "\n" . $aggobj->manifest() . "\n\n";
    print "------------------------------------------------------------\n\n";
}
$slice->UnLock();

if ($failed) {
    if ($ignorefailures) {
        $instance->SetStatus("ready");
    }
    else {
        $instance->SetStatus("failed");
    }
    # Webtask exit status set above.
    $instance->RecordError($webtask->exitcode(),
			   (defined($webtask->output()) ?
			    $webtask->output() : ""));
}
else {
    $instance->SetStatus("ready");

    #
    # If there are still execute services running, lets keep polling
    # using the monitor.
    #
    if ($startuprunning) {
	print "$MANAGEINSTANCE -t $webtask_id monitor $quickvm_uuid -w\n";
	
	system("$MANAGEINSTANCE -t $webtask_id monitor $quickvm_uuid -w")
    }
    else {
	$webtask->Exited(0);
    }
}
exit(0);

#
# Create credentials to access datasets.
#
sub CreateDatasetCreds($$$$$)
{
    my ($xml, $project, $geniuser, $pmsg, $pref) = @_;
    my @credentials = ();
    
    my $rspec = GeniXML::Parse($xml);
    if (! defined($rspec)) {
	print STDERR "CreateDatasetCreds: Could not parse rspec\n";
	return -1;
    }
    foreach my $ref (GeniXML::FindNodes("n:node", $rspec)->get_nodelist()) {
	my $manager_urn  = GetManagerId($ref);
	
	foreach my $blockref (GeniXML::FindNodesNS("n:blockstore", $ref,
				   $GeniXML::EMULAB_NS)->get_nodelist()) {
	    my $dataset_id = GeniXML::GetText("persistent", $blockref);
	    if (!defined($dataset_id)) {
		# persistent is deprecated.
		$dataset_id = GeniXML::GetText("dataset", $blockref);
	    }

	    #
	    # We only care about datasets here, we let the backend
	    # do the error checking on ephemeral blockstores.
	    #
	    next
		if (!defined($dataset_id));

	    my $class = GeniXML::GetText("class", $blockref);
	    if (!defined($class)) {
		$class = "remote";
	    }
	    # Image backed referenced by URL. No checking since the
	    # image has to be global anyway. Needs more thought.
	    next
		if ($class eq "local" && $dataset_id =~ /^(http|https):/);

	    my $dataset_urn = GeniHRN->new($dataset_id);
	    my $dataset = APT_Dataset->LookupByRemoteURN($dataset_urn);
	    if (!defined($dataset)) {
		if ($dataset_urn->domain() eq $OURDOMAIN) {
		    #
		    # Local image backed dataset or lease.
		    #
		    my ($image,$lease);
		    my $pid = $dataset_urn->project();
		    my $id  = $dataset_urn->id();

		    if ($dataset_urn->type() eq "imdataset") {
			$image = Image->Lookup($pid, $id);
			if ($image && !$image->isdataset()) {
			    $$pmsg = "$dataset_urn is an image not a dataset ";
			    return 1;
			}
			#
			# Do a partial permission check here to catch
			# errors early.  The CM will do its own check
			# of course.
			#
			if (!$image->global() &&
			    $PROTOGENI_LOCALUSER && $geniuser->IsLocal() &&
			    !$image->AccessCheck($geniuser->emulab_user(),
						   TB_IMAGEID_ACCESS())) {
			    $$pmsg = "No permission to use $dataset_urn";
			    return 1;
			}
		    }
		    else {
			$lease = Lease->Lookup($pid, $id);
		    }
		    # We cannot generate a credential for "legacy" datasets.
		    # So if it is not global, it cannot be transferred. Maybe
		    # this is okay, we will find out. We could generate a
		    # credential if we needed to.
		    next
			if ($image || $lease);
		}
		$$pmsg = "Dataset '$dataset_urn' does not exist";
		return 1;
	    }
	    #
	    # We do not need a credential for leases, only real users
	    # can use those, and so standard emulab permission checks
	    # are applied at the CM.
	    #
	    next
		if ($dataset->type() ne "imdataset");

	    #
	    # For image backed datasets, we need to send along a credential
	    # that allows the remote CM to securely download the dataset if
	    # it does not already have it. To do that we need to send it a
	    # credential from the CM where the dataset lives. We do that by
	    # requesting a credential, and delegating it to the target CM.
	    #
	    my $pid = $dataset->pid();
	    my $id  = $dataset->dataset_id();
	    my $cmd = "$MANAGEDATASET getcredential -a $manager_urn $pid/$id";
	    my $credential = `$cmd`;
	    if ($?) {
		$$pmsg = "Could not generate credential for $dataset_urn";
		return -1;
	    }
	    push(@credentials, $credential);
	}
    }
    @$pref = @credentials;
    return 0;
}

#
# Create a sliver at a single aggregate. This is called from parrun