#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2006 University of Utah and the Flux Group.
# All rights reserved.
#
use English;
use strict;
use Getopt::Std;
use POSIX qw(setsid);
use POSIX qw(strftime);
use Errno qw(EDQUOT);
use XML::Simple;
use Data::Dumper;

#
# Create a new experiment template. 
#
# Exit codes are important; they tell the web page what has happened so
# it can say something useful to the user. Fatal errors are mostly done
# with die(), but expected errors use this routine. At some point we will
# use the DB to communicate the actual error.
#
# $status < 0 - Fatal error. Something went wrong we did not expect.
# $status = 0 - Everything okay.
# $status > 0 - Expected error. User not allowed for some reason. 
# 
sub usage()
{
    print(STDERR
	  "Usage: template_swapin [-q] [-w] [-s]\n".
	  "         [-S reason] [-L reason] [-a <time>] [-l <time>] ".
	  "-e <eid> <guid/vers>\n".
	  "switches and arguments:\n".
	  "-b       - batchmode; insert into batch queue\n".
	  "-w       - wait for template to be instantiated\n".
	  "-q       - be less chatty\n".
	  "-E <str> - A pithy sentence describing the instance\n".
	  "-x <file>- XML file of parameter bindings\n".
	  "-S <str> - Instance cannot be swapped; must provide reason\n".
	  "-L <str> - Instance cannot be IDLE swapped; must provide reason\n".
	  "-n       - Do not send idle email (internal option only)\n".
	  "-a <nnn> - Auto swapout nnn minutes after instance is swapped in\n".
	  "-l <nnn> - Auto swapout nnn minutes after instance goes idle\n".
	  "-s       - Save disk state on swapout\n".
	  "-e <eid> - The instance name (unique, alphanumeric, no blanks)\n".
	  "<guid/vers> - GUID and version to swapin\n");
    exit(-1);
}
my $optlist	 = "qwe:S:L:na:l:se:x:bE:t:";
my %options      = ();
my $quiet        = 0;
my $waitmode     = 0;
my $batchmode    = 0;
my $foreground   = 0;
my $description;
my $paramfile;
my $guid;
my $version;
my $eid;
my %parameters   = ();

#
# Configure variables
#
my $TB		= "@prefix@";
my $PROJROOT	= "/proj";
my $EVENTSYS	= @EVENTSYS@;
my $TBOPS	= "@TBOPSEMAIL@";
my $TBLOGS	= "@TBLOGSEMAIL@";
my $TBDOCBASE	= "@TBDOCBASE@";
my $TBBASE	= "@TBBASE@";
my $CONTROL	= "@USERNODE@";
my $BOSSNODE    = "@BOSSNODE@";
my $OPSDBSUPPORT= @OPSDBSUPPORT@;

# Locals
my $user_name;
my $user_email;
my $dbuid;
my $EVhandle;
my $exptidx;
my $template;
my $instance;
my $logname;
my $template_tag;
my @ExptStates  = ();
# For the END block below.
my $cleaning    = 0;
my $exptcreated = 0;
my $justexit    = 1;

# Programs we need
my $checkquota  = "$TB/sbin/checkquota";
my $batchexp    = "$TB/bin/batchexp";
my $swapexp     = "$TB/bin/swapexp";
my $endexp      = "$TB/bin/endexp";
my $dbcontrol   = "$TB/sbin/opsdb_control";

# Protos
sub ParseArgs();
sub fatal($$);
sub sighandler($);
sub SetupEventHandler();

#
# Testbed Support libraries
#
use lib "@prefix@/lib";
use libdb;
use libtestbed;
use libtblog;
use Template;
use Experiment;
use event;
use libaudit;

# Be careful not to exit on transient error
$libdb::DBQUERY_MAXTRIES = 0;

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

#
# Set umask for start/swap. We want other members in the project to be
# able to swap/end experiments, so the log and intermediate files need
# to be 664 since some are opened for append.
#
umask(0002);

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

#
# Verify user and get his DB uid.
#
if (! UNIX2DBUID($UID, \$dbuid)) {
    tbdie("You do not exist in the Emulab Database!");
}

#
# Get email info for user.
#
if (! UserDBInfo($dbuid, \$user_name, \$user_email)) {
    tbdie("Cannot determine your name and email address.");
}

#
# Before doing anything else, check for overquota ... lets not waste
# our time. Make sure user sees the error by exiting with 1.
#
if (system("$checkquota $dbuid") != 0) {
    tberror("You are over your disk quota on $CONTROL; please cleanup!");
    exit(1);
}

# Now parse arguments.
ParseArgs();

#
# In wait mode, block SIGINT until we spin off the background process.
#
if ($waitmode) {
    $SIG{QUIT} = 'IGNORE';
    $SIG{TERM} = 'IGNORE';
    $SIG{INT}  = 'IGNORE';
}

#
# Grab template and do access check.
#
$template = Template->Lookup($guid, $version);

if (!defined($template)) {
    tbdie("Experiment template $guid/$version does not exist!");
}
if (! TBProjAccessCheck($dbuid,
			$template->pid(), $template->gid(),
			TB_PROJECT_CREATEEXPT)) {
    tberror("You do not have permission to instantiate template ".
	    "$guid/$version");
    exit(1);
}

#
# If we have a parameter file, we need to copyin the values and store
# them in the DB for this experiment. Note that these override existing
# values, so we start with those first.
#
# XXX Do we keep these values in the DB forever? Or just keep the XML file
# around and archived? 
#
$template->FormalParameterList(\%parameters) == 0
    or tbdie("Could not get formal parameter list for $template");

if (defined($paramfile)) {
    my $donebad = 0;
    
    my $parse  = XMLin($paramfile,
		       VarAttr => 'name',
		       ContentKey => '-content',
		       SuppressEmpty => undef);

    foreach my $name (keys(%{ $parse->{'parameter'} })) {
	my $value = $parse->{'parameter'}->{"$name"}->{'value'};

	if (! TBcheck_dbslot($name,
			     "experiment_template_instance_bindings", "name",
			     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    tberror("Illegal characters in parameter name: $name");
	    $donebad++;
	}
	if (defined($value) &&
	    ! TBcheck_dbslot($value,
			     "experiment_template_instance_bindings", "value",
			     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    tberror("Illegal characters in parameter value: $value");
	    $donebad++;
	}
	# DB records inserted below, once experiment is pre-loaded.
	# Watch for unwanted parameters.
	$parameters{$name} = $value
	    if (exists($parameters{$name}));
    }
    # User sees this error.
    exit(1)
	if ($donebad);
}

#
# Generate a new template instance record, and get back its index.
# We will finish updating it later.
#
$instance = $template->NewInstance($eid, $dbuid);
if (!defined($instance)) {
    fatal(-1, "Could not insert new experiment instance record!");
}

#
# At this point, we need to force a cleanup no matter how we exit.
# See the END block below.
#
$justexit = 0;

#
# Now insert the binding records so that the parser can get them.
#
if ($paramfile) {
    foreach my $name (keys(%parameters)) {
	my $value = $parameters{$name};

	$instance->NewBinding($name, $value) == 0
	    or fatal(-1, "Error inserting binding into DB!");
    }
}

#
# For now, I am not worrying about reparsing the experiment. Just make
# a copy of the existing preload associated with the template. This will
# certainly change later.
#
my $pid    = $template->pid();
my $copyid = $template->pid() . "," . $template->eid();

#
# Go to the background now so we have a proper log of what happened.
#
#
$SIG{TERM} = \&sighandler;

#
# Use the logonly option to audit so that we get a record mailed.
#
if (! ($foreground || $batchmode)) {
    if ($instance->CreateLogFile("swapin", \$logname) < 0) {
	fatal(-1, "Could not create logfile!");
    }

    if (my $childpid = AuditStart(LIBAUDIT_DAEMON, $logname,
				  LIBAUDIT_LOGONLY|LIBAUDIT_NODELETE)) {
	#
	# Parent exits normally, unless in waitmode. We have to set
	# justexit to make sure the END block below does not run.
	#
	$justexit = 1;

	if (!$waitmode) {
	    #
	    # Before we can actually exit, we need to wait. Totally ick;
	    # the logfile stuff needs work.
	    #
	    while (1) {
		my ($tmp1, $tmp2);

		last
		    if (TBExptGetLogFile($pid, $eid, \$tmp1, \$tmp2));

		sleep(2);
	    }
	    if ($batchmode) {
		print("Experiment $pid/$eid has entered the batch system.\n".
		      "You will be notified when it is fully instantiated.\n")
		    if (! $quiet);
	    }
	    else {
		print("Experiment $pid/$eid is now being instantiated.\n".
		      "You will be notified via email when this is done.\n")
		    if (! $quiet);
	    }
	    exit(0);
	}
	print("Waiting for experiment $eid to fully instantiate.\n")
	    if (! $quiet);
	    
	if (-t STDIN && !$quiet) {
	    print("You may type ^C at anytime; you will be notified via ".
		  "email.\n".
		  "You will not actually interrupt the instantiation.\n");
	}
	
	# Give child a chance to run.
	select(undef, undef, undef, 0.25);
	
	#
	# Reset signal handlers. User can now kill this process, without
	# stopping the child.
	#
	$SIG{TERM} = 'DEFAULT';
	$SIG{INT}  = 'DEFAULT';
	$SIG{QUIT} = 'DEFAULT';

	#
	# Wait until child exits or until user gets bored and types ^C.
	#
	waitpid($childpid, 0);
	
	print("Done. Exited with status: $?\n")
	    if (! $quiet);
	exit($? >> 8);
    }
    TBdbfork();
}

#
# Build up arguments to batchexp. I do not want to bother with shell
# escapes, hence the list argument to system instead of a long string.
# Be sure to leave it this way, or perl will invoke a shell and that
# would be a really bad thing.
#
# Note special -x option.
#
my @arguments =
    ($batchexp, "-x", $template->eid(), "-y", $instance->idx(), "-q", "-f",
     "-p", $pid, "-e", $eid, "-g", $template->gid(),
     "-E", "'Experiment Template Instantiation $guid/$version' ",
     "-c" , $copyid);

# All the other goo.
push(@arguments, "-i")
    if (!$batchmode);
push(@arguments, "-s")
    if (defined($options{"s"}));
push(@arguments, "-n")
    if (defined($options{"n"}));
push(@arguments, ("-S", $options{"S"}))
    if (defined($options{"S"}));
push(@arguments, ("-L", $options{"L"}))
    if (defined($options{"L"}));
push(@arguments, ("-l", $options{"l"}))
    if (defined($options{"l"}));
push(@arguments, ("-a", $options{"a"}))
    if (defined($options{"a"}));
push(@arguments, ("-t", $options{"t"}))
    if (defined($options{"t"}));

# Now invoke batchexp.
system(@arguments);
fatal($? >> 8, "Could not pre-instantiate the experiment")
    if ($?);

# Need to kill the experiment if we fail after this point.
$exptcreated = 1;

#
# Now we can do this ...
#
if (defined($logname) && ! ($foreground || $batchmode)) {
    TBExptSetLogFile($pid, $eid, $logname);
    TBExptOpenLogFile($pid, $eid);
}

# Grab the experiment record for below.
my $experiment = Experiment->Lookup($pid, $eid);
if (!defined($experiment)) {
    fatal(-1, "Experiment $pid/$eid could not be found after creation!");
}
$exptidx = $experiment->idx();

#
# Templates always get a DB; override the NS file setting of dpdb, and
# then call out to have it created.
#
if ($OPSDBSUPPORT) {
    my %args = ();
    
    $args{'dpdb'} = 1;

    $experiment->Update(\%args) == 0
	or fatal(-1, "Could not update experiment record!");
    
    if (system("$dbcontrol addexpdb $pid $eid")) {
	fatal(-1, "$dbcontrol addexpdb failed!");
    }
    $experiment->Refresh();
}

#
# Need the current archive tag so we know how to find the datastore that
# corresponds to this instance, at some later date.
#
libArchive::TBExperimentArchiveTag($template->pid(),
				   $template->eid(), \$template_tag) == 0
    or fatal(-1, "Could not get current tag for $template");

#
# Update the Instance
#
my %args = ();
$args{'exptidx'}      = $exptidx;
$args{'template_tag'} = $template_tag;

$instance->Update(0, \%args) == 0
    or fatal(-1, "Could not update experiment instance record!");

# Event connect now that experiment is created.
SetupEventHandler();

my $workdir = $experiment->WorkDir();
my $userdir = $experiment->UserDir();

#
# Now we stash the parameter file.
#
if ($paramfile) {
    system("/bin/cp", $paramfile, $userdir . "/archive/parameters.xml") == 0
	or tbdie("Could not copy out $paramfile");
}

#
# Copy the datastore into the experiment directory. This really needs
# to be a checkout, and it really needs to go someplace other then the
# exp directory. Anyway, once that is done, add an environment
# variable the user can reference for finding files in the datastore.
#
my $instance_path = $userdir;
$instance->CopyDataStore($template_tag,
			 "$instance_path/template_datastore") == 0
    or fatal(-1, "Could not copy datastore ($template_tag) to instance");

# Ditto for dynamic events.
$instance->CopyTemplateEvents() == 0
    or fatal(-1, "Could not copy template events to instance");

# We munge the environment variables.
$instance->InitializeEnvVariables(\%parameters) == 0
    or fatal(-1, "Could not add new environment variables to instance");
    
print "Writing environment strings ...\n";
$instance->WriteEnvVariables() == 0
    or fatal(-1, "Could not write environment strings for program agents");

#
# Now do the swapin (or it gets queued if a batch experiment).
#
@arguments = ($swapexp, "-q", "-x", "-s", "in", $pid, $eid);

system(@arguments);
fatal($? >> 8, "Could not instantiate the experiment")
    if ($?);

#
# We will spew forth info to the user each time the batch daemon tries to
# swap it in. 
#
if ($batchmode) {
    #
    # Spin waiting for the state to change in swapexp. We are waiting for
    # it to swapin or go back to swapped.
    #
    my $queued = 0;
    
    while (1) {
	@ExptStates = ();
	event_poll_blocking($EVhandle, 500);

	next
	    if (! @ExptStates);

	foreach my $state (@ExptStates) {
	    print "$state\n";
	    
	    if ($state eq EXPTSTATE_ACTIVATING()) {
		print "Experiment is starting a swapin attempt ...\n";
	    }
	    elsif ($state eq EXPTSTATE_ACTIVE()) {
		print "Experiment swapped in!\n";
		goto done;
	    }
	    elsif ($state eq EXPTSTATE_QUEUED()) {
		# Failed to swapin; still queued in the batch system.
		if (! $queued) {
		    print "Experiment has entered the batch system\n";
		    $queued = 1;
		}
		else {
		    print "Experiment swapin attempt failed.\n";
		}
	    }
	    elsif ($state eq EXPTSTATE_SWAPPED()) {
		# Dumped out of the batch system for some reason.
		print "Experiment ha been removed from the batch queue.\n";

		#
		# We are done; remove record of this attempt and exit.
		#
		fatal(1, "Experiment has been removed from the batch queue");
	    }
	}
    }
  done:
}

#
# All instances currently start with a default run.
#
$instance->NewRun($eid, $description) == 0
    or fatal(-1, "Could not insert experiment new run record!");

#
# And the bindings for the default run ...
#
foreach my $name (keys(%parameters)) {
    my $value = $parameters{$name};

    $instance->NewRunBinding($name, $value) == 0
	or fatal(-1, "Error inserting run binding into DB!");
}

$instance->StartFirstRun() == 0
    or fatal(-1, "Could not update start time in instance record!");

# Stop the web interface from spewing.
TBExptCloseLogFile($pid, $eid)
    if (defined($logname) && !$batchmode);

# Email is sent from libaudit at exit ...
exit(0);

#
# Parse command arguments. Once we return from getopts, all that are
# left are the required arguments.
#
sub ParseArgs()
{
    if (! getopts($optlist, \%options)) {
	usage();
    }

    if (@ARGV != 1) {
	usage();
    }
    #
    # Pick up guid/version first and untaint.
    #
    my $tmp = shift(@ARGV);

    if ($tmp =~ /^([\w]*)\/([\d]*)$/) {
	$guid = $1;
	$version = $2;
    }
    else {
	tbdie("Bad data in argument: $tmp");
    }

    if (defined($options{"e"})) {
	$eid = $options{"e"};

	if ($eid =~ /^([-\w]+)$/) {
	    $eid = $1;
	}
	else {
	    tbdie("Bad data in argument: $eid.");
	}
	if (! TBcheck_dbslot($eid, "experiments", "eid",
			   TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    tbdie("Improper experiment name (id)!");
	}
    }
    else {
	tberror("Must provide an experiment ID (-e option)!");
	exit(1);
    }

    if (defined($options{"q"})) {
	$quiet = 1;
    }
    if (defined($options{"w"})) {
	$waitmode = 1;
    }
    if (defined($options{"b"})) {
	$batchmode = 1;
    }
    if (defined($options{"S"})) {
	if ($options{"S"} =~ /^(.*)$/) {
	    $options{"S"} = $1;
	}
    }
    if (defined($options{"L"})) {
	if ($options{"L"} =~ /^(.*)$/) {
	    $options{"L"} = $1;
	}
    }
    if (defined($options{"l"})) {
	if ($options{"l"} =~ /^(.*)$/) {
	    $options{"l"} = $1;
	}
    }
    if (defined($options{"a"})) {
	if ($options{"a"} =~ /^(.*)$/) {
	    $options{"a"} = $1;
	}
    }
    if (defined($options{"t"})) {
	if ($options{"t"} =~ /^(.*)$/) {
	    $options{"t"} = $1;
	}
    }

    if (defined($options{"x"})) {
	my $inputfile = $options{"x"};

	# Note different taint check (allow /).
	if ($inputfile =~ /^([-\w\.\/]+)$/) {
	    $inputfile = $1;
	}
	else {
	    tbdie("Bad data in parameter file: $inputfile");
	}

	#
	# Called from ops interactively. Make sure NS file in /proj or /users.
	#
	# Use realpath to resolve any symlinks.
	#
	my $translated = `realpath $inputfile`;
	if ($translated =~ /^([-\w\.\/]+)$/) {
	    $inputfile = $1;
	}
	else {
	    tbdie("Bad data returned by realpath: $translated");
	}

	#
	# The file must reside in /proj, /groups, or /users. Since this script
	# runs as the caller, regular file permission checks ensure its a file
	# the user is allowed to use. /tmp/$pid-$eid.nsfile.XXXXX also allowed
	# since this script is invoked directly from web interface.
	#
	if (! ($inputfile =~ /^\/tmp\/[-\w]+-\d+\.xml/) &&
	    ! ($inputfile =~ /^\/tmp\/\d+\.xml/) &&
	    ! ($inputfile =~ /^\/var\/tmp\/php\w+/) &&
	    ! ($inputfile =~ /^\/proj/) &&
	    ! ($inputfile =~ /^\/groups/) &&
	    ! ($inputfile =~ /^\/users/)) {
	    tberror("$inputfile does not resolve to an allowed directory!");
	    # Note positive status; so error goes to user not tbops.
	    exit(1);
	}
	$paramfile = $inputfile;
    }

    if (defined($options{"E"})) {
	if (! TBcheck_dbslot($options{"E"},
			     "experiment_templates", "description",
			     TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	    tbdie("Improper template description!");
	}
	$description = $options{"E"};
    }
}

#
# Subscribe to experiment state change events.
#
sub SetupEventHandler()
{
    my $port = @BOSSEVENTPORT@;
    my $URL  = "elvin://localhost:$port";
    
    # Connect to the event system, and subscribe the the events we want
    $EVhandle = event_register($URL, 0);
    
    if (!$EVhandle) {
	tbdie("Unable to register with event system\n");
    }

    my $tuple = address_tuple_alloc();
    if (!$tuple) {
	tbdie("Could not allocate an address tuple\n");
    }

    %$tuple = ( objtype   => libdb::TBDB_TBEVENT_EXPTSTATE(),
		objname   => "$pid/$eid",
		expt      => "$pid/$eid",
		host      => $BOSSNODE,
	      );
    
    if (!event_subscribe($EVhandle, \&EventHandler, $tuple)) {
	tbdie("Could not subscribe to events\n");
    }
}

#
# Callback for above.
#
sub EventHandler($$$) {
    my ($handle,$notification,undef) = @_;
    
    my $objname   = event_notification_get_objname($handle,$notification);
    my $eventtype = event_notification_get_eventtype($handle,$notification);

    print "$objname, $eventtype\n";

    return
	if ($objname ne "$pid/$eid");

    push(@ExptStates, $eventtype);
}

#
# Cleanup the mess.
#
sub cleanup()
{
    if ($exptcreated) {
	exit(-1)
	    if (!TBExptIDX($pid, $eid, \$exptidx));
		
	system("$endexp -x -q -w $pid $eid");
	exit(-1)
	    if ($?);
    }
    $instance->Delete()
	if (defined($instance));

    # Stop the web interface from spewing.
    TBExptCloseLogFile($pid, $eid)
	if (defined($logname) && !$batchmode);
}

sub fatal($$)
{
    my ($errorstat, $msg) = @_;
    
    tberror $msg;
    tbinfo "Cleaning up and exiting with status $errorstat ...";

    #
    # This exit will drop into the END block below.
    # 
    exit($errorstat);
}

sub sighandler ($) {
    my ($signame) = @_;
    
    $SIG{TERM} = 'IGNORE';
    my $pgrp = getpgrp(0);
    kill('TERM', -$pgrp);
    sleep(1);
    fatal(-1, "Caught SIG${signame}! Killing experiment setup ...");
}

END {
    # Normal exit, nothing to do.
    if (!$? || $justexit) {
	return;
    }
    my $saved_exitcode = $?;
    
    if ($cleaning) {
	#
	# We are screwed; a recursive error. Someone will have to clean
	# up by hand. 
	#
	SENDMAIL($TBOPS, 
		 "Template Creation Failure: $pid/$eid",
		 "Recursive error in cleanup! This is very bad.");
	$? = $saved_exitcode;
	return;
    }
    $cleaning = 1;
    cleanup();
    $? = $saved_exitcode;
}