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

#
# Portal stuff.
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA    = "Exporter";
@EXPORT = qw ( );

# Must come after package declaration!
use emdb;
use emutil;
use WebTask;
use libtestbed;
use libEmulab;
use GeniResponse;
use GeniSlice;
use GeniCM;
use GeniHRN;
use GeniUtil;
use Reservation;
use GeniCredential;
use GeniStd;
use English;
use Data::Dumper;
use Date::Parse;
use POSIX qw(strftime);
use Time::Local;
use File::Temp qw(tempfile);
use Project;
use NodeType;

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $MAINSITE 	   = @TBMAINSITE@;
my $OURDOMAIN      = "@OURDOMAIN@";
my $IDLESTATS      = "$TB/bin/idlestats";
my $SUDO           = "/usr/local/bin/sudo";
my $SSH            = "/usr/bin/ssh";
my $WAP            = "$TB/sbin/withadminprivs";
my $API_VERSION    = 1.0;

#
# Check permission. At the moment, only the Mothership can issue requests
# and only the Cloudlab clusters will accept them.
#
sub CheckPermission($)
{
    my ($rootonly) = @_;
    my $myurn = $ENV{"MYURN"};

    my $hrn = GeniHRN->new($ENV{"GENIURN"});
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"Could not parse GENIURN")
	if (!defined($hrn));
    
    return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				"Only the Mothership or local cluster ".
				"can access this interface")
	if (! ($hrn->authority() eq "emulab.net" ||
	       $hrn->authority() eq $OURDOMAIN));

    return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
				"Only the root authority ".
				"can access this interface")
	if (defined($rootonly) && $rootonly &&
	    ! ($hrn->IsAuthority() && $hrn->IsRoot()));

    return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
			"Only Cloudlab clusters permit this interface")
	if (! ($OURDOMAIN eq "emulab.net" ||
	       $OURDOMAIN eq "apt.emulab.net" ||
	       $OURDOMAIN eq "utah.cloudlab.us" ||
	       $OURDOMAIN eq "wisc.cloudlab.us" ||
	       $OURDOMAIN eq "clemson.cloudlab.us" ||
	       $OURDOMAIN eq "lab.onelab.eu"));

    return 0;
}

#
# Tell the client what API revision we support.  The correspondence
# between revision numbers and API features is to be specified elsewhere.
# No credentials are required.
#
sub GetVersion()
{
    my $hasperm = CheckPermission(0);
    return $hasperm
	if (GeniResponse::IsError($hasperm));
	    
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $API_VERSION);
}

#
# Return the InUse info, which includes the pre-reserve info.
#
sub InUse()
{
    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));
    my $autoswap_max;
    if (!GetSiteVar("general/autoswap_max", \$autoswap_max)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    # sitevar in hours, convert to seconds
    $autoswap_max *= 3600;

    my @blob = ();

    my $query_result =
	DBQueryWarn("select n.node_id,n.type,r.pid,r.eid,n.reserved_pid,".
		    "  unix_timestamp(s.expires),e.autoswap, ".
		    "  (e.autoswap_timeout - ".
		    "   ((unix_timestamp(now()) - ".
		    "     unix_timestamp(stats.swapin_last))/60)) as ttl, ".
		    "  u.uid,stats.slice_uuid,cert.urn,e.swappable, ".
		    "  s.lockdown,unix_timestamp(stats.swapin_last) ".
		    "  from nodes as n ".
		    "left join reserved as r on r.node_id=n.node_id ".
		    "left join node_types as t on t.type=n.type ".
		    "left join experiments as e on e.idx=r.exptidx ".
		    "left join experiment_stats as stats on ".
		    "     stats.exptidx=e.idx ".
		    "left join `geni-cm`.geni_slices as s on ".
		    "     s.uuid=stats.slice_uuid ".
		    "left join `geni-cm`.geni_certificates as cert on ".
		    "     cert.uuid=stats.slice_uuid ".
		    "left join users as u on u.uid_idx=e.swapper_idx ".
		    "where n.role='testnode' and t.class='pc' ".
		    "order by n.node_id");
    while (my ($node_id,$type,$pid,$eid,$reserved_pid,$expires,
	       $autoswap,$ttl,$uid,$slice_uuid,$slice_urn,
	       $swappable,$slice_lockdown,$swapin_time) =
	   $query_result->fetchrow_array()) {
	my $maxttl;
	
	#
	# Try and compute a time the node will be released. This is a guess
	# at best, lots of things can change as soon as we calculate it.
	#
	if (defined($expires)) {
	    if ($slice_lockdown) {
		$ttl = "";
	    }
	    else {
		$ttl = $expires - time();
	    }
	}
	elsif (defined($eid)) {
	    if (!$swappable) {
		$ttl = "";
	    }
	    elsif ($autoswap && defined($ttl)) {
		$ttl = $ttl * 60;
		$maxttl = $autoswap_max - (time() - $swapin_time);
		if ($ttl > $maxttl) {
		    # Admin override.
		    $maxttl = $ttl;
		}
	    }
	    else {
		$ttl = "";
	    }
	}
	else {
	    $ttl = "";
	}
	push(@blob, {"node_id"      => $node_id,
		     "type"         => $type,
		     "pid"          => $pid || "",
		     "eid"          => $eid || "",
		     "uid"          => $uid || "",
		     "ttl"          => $ttl,
		     "maxttl"       => $maxttl || "",
		     "slice_urn"    => $slice_urn || "",
		     "slice_uuid"   => $slice_uuid || "",
		     "reserved_pid" => $reserved_pid || ""});
    }
    my $results = {"api_version"  => $API_VERSION,
		   "details"      => \@blob};
		  
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $results);
}

#
# Return pre-reservation details.
#
sub PreReservations()
{
    my @blob = ();
    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    my $query_result =
	DBQueryWarn("select p.*,nr.node_id,n.type as node_type".
		    "  from project_reservations as p ".
		    "left join node_reservations as nr on ".
		    "     nr.pid_idx=p.pid_idx and ".
		    "     nr.reservation_name=p.name ".
		    "left join nodes as n on n.node_id=nr.node_id ".
		    "order by p.pid,p.name,n.node_id");

    return GeniResponse->Create(GENIRESPONSE_ERROR)
	if (!$query_result);

    while (my $row = $query_result->fetchrow_hashref()) {
      nextpid:
	my @nodes    = ();
	my $pid      = $row->{'pid'};
	my $name     = $row->{'name'};
	my $count    = $row->{'count'};
	my $priority = $row->{'priority'};
	my $active   = $row->{'active'};
	my $terminal = $row->{'terminal'};
	my $types    = $row->{'types'};
	my $creator  = $row->{'creator'};
	my $created  = TBDateStringGMT($row->{'created'});
	my $start    = TBDateStringGMT($row->{'start'})
	    if (defined($row->{'start'}));
	my $end      = TBDateStringGMT($row->{'end'})
	    if (defined($row->{'end'}));
	my @prereserved = ();

	# Which nodes have actually been pre-reserved.
	my $current_result =
	    DBQueryWarn("select node_id,type from nodes ".
			"where reserved_pid='$pid' and ".
			"      reservation_name='$name'");
	return GeniResponse->Create(GENIRESPONSE_ERROR)
	    if (!$current_result);
	while (my ($node_id, $ntype) = $current_result->fetchrow_array()) {
	    push(@prereserved,
		 {"node_id" => $node_id, "type" => $ntype});
	}
	#
	# If this is a reservation for specific node(s), eat those rows.
	#
	while (defined($row->{'node_id'}) &&
	       $row->{'pid'} eq $pid && $row->{'name'} eq $name) {
	    push(@nodes,
		 {"node_id" => $row->{'node_id'},
		  "type"    => $row->{'node_type'}});
	    
	    $row = $query_result->fetchrow_hashref();
	    last
		if (!defined($row));
	}
	push(@blob, {"nodes"        => \@nodes,
		     "pid"          => $pid,
		     "name"         => $name,
		     "count"        => $count,
		     "prereserved"  => \@prereserved,
		     "types"        => $types || "",
		     "priority"     => $priority,
		     "created"      => $created,
		     "creator"      => $creator,
		     "start"        => $start || "",
		     "end"          => $end || "",
		     "active"       => $active,
		     "terminal"     => $terminal,
	     });
	# We ate the last row.
	last
	    if (!defined($row));
	# We ate the first row of the next reservation.
	goto nextpid
	    if (! ($row->{'pid'} eq $pid && $row->{'name'} eq $name));
    }
    my $results = {"api_version"  => $API_VERSION,
		   "details"      => \@blob};
		  
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $results);
}

#
# Return utilization data for the nodes in a slice.
#
sub SliceUtilizationData($)
{
    my ($argref)  = @_;
    my $slice_urn = $argref->{'slice_urn'};
    my %blob      = ();
    
    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    my $slice = GeniSlice->Lookup($slice_urn);    
    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (!defined($slice));
    
    my $experiment = $slice->GetExperiment();
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"No experiment for $slice")
	if (!defined($experiment));

    my @nodes = $experiment->NodeList(0, 1);
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"No nodes is $slice")
	if (!@nodes);

    #
    # Build up a per-type summary count, to which we will add the
    # current total/free counts. 
    #
    my %typelist = ();
    
    foreach my $node (@nodes) {
	my %stats = ();
	$stats{"nodetype"} = $node->type();

	# Type counts.
	if (!exists($typelist{$node->type()})) {
	    $typelist{$node->type()} = {"count" => 0};
	}
	$typelist{$node->type()}->{"count"}++;
	
	my ($idletime, $staleness, $stale) = $node->IdleData();
	if (defined($idletime)) {
	    $stats{"idledata"} = {
		"idletime"   => $idletime,
		"staleness"  => $staleness,
		"stale"      => $stale,
	    };
	}
	$stats{"eventstate"} = $node->eventstate();

	my $rusage = $node->RusageData();
	if (defined($rusage)) {
	    $stats{"rusage"} = $rusage;
	}
	my ($status,$status_stamp) = $node->GetStatus();
	if (defined($status)) {
	    $stats{"status"} = {
		"status"    => $status,
		"timestamp" => $status_stamp,
	    };
	}
	$blob{$node->node_id()} = \%stats;
    }
    #
    # Finish up the per-type info, adding total/inuse/preserved.
    #
    foreach my $type (keys(%typelist)) {
	my $typeinfo = NodeType->Lookup($type);
	next
	    if (!defined($typeinfo));

	if ($typeinfo->isvirtnode()) {
	    $typelist{$typeinfo->type()}->{"total"} = 0;
	    $typelist{$typeinfo->type()}->{"free"}  = 0;
	    next;
	}
	
	my $counts = $typeinfo->Counts();
	if (defined($counts)) {
	    $typelist{$typeinfo->type()}->{"total"} = $counts->{"total"};
	    $typelist{$typeinfo->type()}->{"free"}  = $counts->{"free"};
	}
    }
    my $results = {"api_version"  => $API_VERSION,
		   "typeinfo"     => \%typelist,
		   "details"      => {
		       "nodes" => \%blob,
		   }};
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $results);
}

#
# Return utilization data for the nodes in a slice.
#
sub SliceIdleData($)
{
    my ($argref)  = @_;
    my $slice_urn = $argref->{'slice_urn'};
    my %blob      = ();
    
    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    my $slice = GeniSlice->Lookup($slice_urn);    
    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (!defined($slice));
    
    my $experiment = $slice->GetExperiment();
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"No experiment for $slice")
	if (!defined($experiment));

    my $pid  = $experiment->pid();
    my $eid  = $experiment->eid();
    my $swapped = str2time($experiment->swapin_last());
    my $limit   = time() - (3600 * 24 * 3);
    if ($limit < $swapped) {
	$limit = $swapped;
    }
    $limit = emutil::TBDateStringLocal($limit);

    GeniUtil::FlipToElabMan();
    if (! open(IDLE, "$WAP $IDLESTATS -s -R -B -S '$limit' -e $pid,$eid |")) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not start idlestats")
    }
    my $output = "";
    while (<IDLE>) {
	$output .= $_;
    }
    if (! close(IDLE)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    ($! ? "Pipe error running idlestats: $!" :
				     "idlestats exited with $?") .
				    "\n" . $output);
    }
    #
    # We get a giant json encoded string back.
    #
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $output);
}

#
# Return openstack data for the nodes in a slice.
#
sub SliceOpenstackData($)
{
    my ($argref)  = @_;
    my $slice_urn = $argref->{'slice_urn'};
    my $client_id = $argref->{'client_id'};
    my %blob      = ();

    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    if ($client_id !~ /^[-\w]+$/) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS)
    }

    my $slice = GeniSlice->Lookup($slice_urn);    
    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (!defined($slice));
    
    my $experiment = $slice->GetExperiment();
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"No experiment for $slice")
	if (!defined($experiment));
    my $node = $experiment->VnameToNode($client_id);
    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				"No such controller node for $slice")
	if (!defined($node));
    my $node_id = $node->node_id();

    my $sshopts  = "-o ServerAliveInterval=10 -o ServerAliveCountMax=1 ";
    $sshopts    .= "-o ConnectTimeout=10 ";
    $sshopts    .= "-o BatchMode=yes -o StrictHostKeyChecking=no ";
    my $sshcmd   = "cat /root/setup/cloudlab-openstack-stats.json";

    $EUID = $UID = 0;
    my $output = GeniUtil::ExecQuiet("$SUDO $SSH $sshopts $node_id '$sshcmd'");
    if ($?) {
	GeniUtil::FlipToGeniUser();
	print STDERR "Error getting json from $node_id: $output\n";
	#
	# See if it is cause the file does not exist, we want to tell
	# the caller so it does not keep asking.
	#
	if ($output =~ /No such file/im) {
	    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
					"No json file on $node_id");
	}
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
			    "Error getting json from $node_id: $output");
    }
    GeniUtil::FlipToGeniUser();    
    #
    # We get a json encoded string back.
    #
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $output);
}

#
# Check Reservation request for a slice. 
#
sub SliceCheckReservation($)
{
    my ($argref)  = @_;
    my $slice_urn = $argref->{'slice_urn'};
    my $expiration= $argref->{'expiration'};
    my %blob      = ();
    my $reserror;

    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    # Gack, why does Frontier do this. It is stupid.
    if (ref($expiration) eq 'Frontier::RPC2::DateTime::ISO8601') {
	$expiration = $expiration->value;
    }
    # Convert to a localtime.
    $expiration = eval { timegm(strptime($expiration)); };
    if ($@) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef, $@);
    }
    if (!defined($expiration)) {
	GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
			     "Could not parse expiration");
    }
    my $slice = GeniSlice->Lookup($slice_urn);    
    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (!defined($slice));

    if (Reservation->ExtendSlice($slice, $expiration, \$reserror, 1)) {
	Reservation->FlushAll();
	return GeniResponse->Create(GENIRESPONSE_REFUSED, undef, $reserror);
    }
    Reservation->FlushAll();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Get maximum allowed extension for a slice.
#
sub SliceMaxExtension($)
{
    my ($argref)  = @_;
    my $slice_urn = $argref->{'slice_urn'};
    my %blob      = ();
    my $max;
    my $reserror;

    my $hasperm = CheckPermission(1);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    my $slice = GeniSlice->Lookup($slice_urn);    
    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (!defined($slice));

    if (Reservation->MaxSliceExtension($slice, \$max, \$reserror)) {
	Reservation->FlushAll();
	return GeniResponse->Create(GENIRESPONSE_REFUSED, undef, $reserror);
    }
    Reservation->FlushAll();
    $max = TBDateStringGMT($max);
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $max);
}

#
# Attempt a reservation.
#
sub Reserve($)
{
    my ($argref)  = @_;
    my %blob      = ();
    my $reserror;

    my $hasperm = CheckPermission(0);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    #
    # We want to support admins creating reservations for projects they
    # are not a member of. But we need to have a local account for that
    # remote admin, and for that we need a user credential. But we also
    # need a local project, but for that we just need the project urn.
    #
    # Otherwise we get a project credential issued to a user in that
    # project.
    #
    if (!exists($argref->{'credentials'})) {
	return GeniResponse->MalformedArgsResponse("Missing credentials")
    }
    my ($geniuser, $project) =
	Credential2UserProject($argref->{'credentials'});

    return $geniuser
	if (GeniResponse::IsResponse($geniuser));
    return GeniResponse->MalformedArgsResponse("Not a local user")
	if (!$geniuser->IsLocal());

    #
    # No project, we need to have a project urn.
    #
    if (!defined($project)) {
	return GeniResponse->MalformedArgsResponse("Missing project URN")
	    if (!exists($argref->{'project_urn'}));
	return GeniResponse->MalformedArgsResponse("Invalid project URN")
	    if (!GeniHRN::IsValid($argref->{'project_urn'}));
	my $hrn = GeniHRN->new($argref->{'project_urn'});
	return GeniResponse->MalformedArgsResponse("Mismatching project URN")
	    if ($hrn->domain() ne
		$geniuser->emulab_user()->nonlocalurn()->domain());

	my $group = GeniUtil::GetHoldingProject($hrn,undef,1);
	return $group
	    if (GeniResponse::IsResponse($group));
	$project = $group->GetProject();
    }
    my $pid = $project->pid();
    my $uid = $geniuser->emulab_user()->uid();

    #
    # Required arguments.
    #
    foreach my $field ("count", "start", "end", "type") {
	return GeniResponse->MalformedArgsResponse("Missing $field")
	    if (! (exists($argref->{$field}) && $argref->{$field} ne ""));
    }
    my $count = $argref->{"count"};
    my $start = $argref->{"start"};
    my $end   = $argref->{"end"};
    my $type  = $argref->{"type"};
    my $check = (exists($argref->{"check"}) && $argref->{"check"} ? 1 : 0);
    my $reason= (exists($argref->{"reason"}) ? $argref->{"reason"} : undef);
    my $update= (exists($argref->{"update"}) ? $argref->{"update"} : undef);

    return GeniResponse->MalformedArgsResponse("Invalid count")
	if ($count !~ /^\d+$/);
    return GeniResponse->MalformedArgsResponse("Invalid type")
	if ($type !~ /^[-\w]+$/);
    return GeniResponse->MalformedArgsResponse("Invalid update")
	if (defined($update) && $update !~ /^\d+$/);

    if (defined($reason) &&
	!TBcheck_dbslot($reason, "default", "tinytext",
			TBDB_CHECKDBSLOT_WARN|TBDB_CHECKDBSLOT_ERROR)) {
	return GeniResponse->MalformedArgsResponse("Invalid reason")
    }
    # Gack, why does Frontier do this. It is stupid.
    if (ref($start) eq 'Frontier::RPC2::DateTime::ISO8601') {
	$start = $start->value;
    }
    if (ref($end) eq 'Frontier::RPC2::DateTime::ISO8601') {
	$end = $end->value;
    }
    # Convert to a localtime.
    $start = eval { timegm(strptime($start)); };
    if ($@) {
	return GeniResponse->MalformedArgsResponse("Start time: $@");
    }
    return GeniResponse->MalformedArgsResponse("Start time: ".
					       "Could not parse date")
	if (!defined($start));
    $end = eval { timegm(strptime($end)); };
    if ($@) {
	return GeniResponse->MalformedArgsResponse("End time: $@");
    }
    return GeniResponse->MalformedArgsResponse("End time: Could not parse date")
	if (!defined($end));

    my $nodetype = NodeType->Lookup($type);
    return GeniResponse->SearchFailedResponse("No such type")
	if (!defined($type));

    #
    # It would be great to check permission here if an update, but without
    # a concept of remote admin, this is not possible.
    #
    if (defined($update)) {
	my $reservation = Reservation->Lookup($update);
	return GeniResponse->SearchFailedResponse("No such reservation")
	    if (!defined($reservation));
    }

    # Use a webtask to get back output.
    my $webtask = WebTask->CreateAnonymous();
    return GeniResponse->Create(GENIRESPONSE_ERROR)
	if (!defined($webtask));

    my $args = ($check ? "-n " : "") .
	(defined($update) ? "-m $update " : "") .
	"-T " . $webtask->task_id() . " ".
	"-U $uid -t $type -s $start -e $end $pid $count";

    # Write the reason to a tempfile to pass in. This will auto unlink.
    my $fp;
    if (defined($reason)) {
	$fp = File::Temp->new();
	print $fp $reason;
	$args = "-N $fp $args";
	chmod(0755, "$fp");
    }

    GeniUtil::FlipToElabMan();
    my $output = GeniUtil::ExecQuiet("$WAP $TB/sbin/reserve $args");
    
    if ($?) {
	GeniUtil::FlipToGeniUser();
	$webtask->Refresh();
	my $code = $webtask->code();
	my $mesg = $webtask->output();
	$webtask->Delete();
	if (!defined($mesg)) {
	    $mesg = $output;
	}
	return GeniResponse->Create(GENIRESPONSE_REFUSED, $code, $mesg);
    }
    GeniUtil::FlipToGeniUser();
    $webtask->Delete();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Reservation list or just one.
#
sub Reservations($)
{
    my ($argref)  = @_;
    my %results   = ();
    my $reserror;
    my $query_result;
    my $idx;

    my $hasperm = CheckPermission(0);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    if (exists($argref->{'idx'})) {
	$idx = $argref->{'idx'};

	return GeniResponse->MalformedArgsResponse("Invalid idx")
	    if ($idx !~ /^\d+$/);
    }

    #
    # If the root authority is asking, then no perm checks are necessary.
    # and we send back the entire list. Otherwise return only those
    # reservations granted by the credential, which should be a project
    # credential or a user (self) credential.
    #
    if (!exists($argref->{'credentials'})) {
	my $hrn = GeniHRN->new($ENV{"GENIURN"});
	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN)
	    if (! ($hrn->IsAuthority() && $hrn->IsRoot()));
	
	$query_result =
	    DBQueryWarn("select *,UNIX_TIMESTAMP(start) as start, ".
			"   UNIX_TIMESTAMP(end) as end, ".
			"   UNIX_TIMESTAMP(created) as created ".
			"  from future_reservations ".
			(defined($idx) ? "where idx='$idx' " : "") .
			"order BY start");
    }
    else {
	my $credentials = $argref->{'credentials'};	
	my ($geniuser,$project) = Credential2UserProject($credentials);

	return $geniuser
	    if (GeniResponse::IsResponse($geniuser));

	if (defined($project)) {
	    my $pid = $project->pid();
	    $query_result =
		DBQueryWarn("select *,UNIX_TIMESTAMP(start) as start, ".
			    "   UNIX_TIMESTAMP(end) as end, ".
			    "   UNIX_TIMESTAMP(created) as created ".
			    "  from future_reservations ".
			    "where pid='$pid' ".
			    (defined($idx) ? "and idx='$idx'" : ""));
	}
	else {
	    my $uid = $geniuser->uid();
	    $query_result =
		DBQueryWarn("select *,UNIX_TIMESTAMP(start) as start, ".
			    "   UNIX_TIMESTAMP(end) as end, ".
			    "   UNIX_TIMESTAMP(created) as created ".
			    "  from future_reservations ".
			    "where uid='$uid'");
	}
    }
    return GeniResponse->Create(GENIRESPONSE_ERROR)
	if (!$query_result);

    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (defined($idx) && !$query_result->numrows);

    while (my $row = $query_result->fetchrow_hashref()) {
	my $blob = {};
   	my $idx  = $row->{'idx'};
	my $pid  = $row->{'pid'};
	my $uid  = $row->{'uid'};
	
	my $project = Project->Lookup($pid);
	if (!defined($project)) {
	    print STDERR "Reservations: No such project $pid\n";
	    next;
	}
	my $user = User->Lookup($uid);
	if (!defined($user)) {
	    print STDERR "Reservations: No such user $uid\n";
	    next;
	}
	$blob->{"idx"}         = $idx;
	$blob->{"project"}     = $project->nonlocalurn();
	$blob->{"user"}        = $user->nonlocalurn();
	$blob->{"nodes"}       = $row->{'nodes'};
	$blob->{"type"}        = $row->{'type'};
	$blob->{"created"}     = TBDateStringGMT($row->{'created'});
	$blob->{"start"}       = TBDateStringGMT($row->{'start'});
	$blob->{"start"}       = TBDateStringGMT($row->{'start'});
	$blob->{"end"}         = TBDateStringGMT($row->{'end'});
	$blob->{"notes"}       = $row->{'notes'} || "";
	$results{"$idx"}       = $blob;
    }
    my $blob = {"api_version"  => $API_VERSION,
		"reservations" => \%results,
    };
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
}

#
# Delete a reservation.
#
sub DeleteReservation($)
{
    my ($argref)  = @_;
    my $project;

    my $hasperm = CheckPermission(0);
    return $hasperm
	if (GeniResponse::IsError($hasperm));

    return GeniResponse->MalformedArgsResponse("Missing reservation ID")
	if (! (exists($argref->{"idx"}) && $argref->{"idx"} ne ""));

    my $idx = $argref->{"idx"};
    return GeniResponse->MalformedArgsResponse("Illegal reservation ID")
	if ($idx !~ /^\d+$/);

    return GeniResponse->MalformedArgsResponse("Missing project")
	if (! (exists($argref->{"project"}) && $argref->{"project"} ne ""));

    my $urn = $argref->{"project"};
    return GeniResponse->MalformedArgsResponse("Illegal project URN")
	if (!GeniHRN::IsValid($urn));
    my $hrn = GeniHRN->new($urn);

    if ($hrn->domain() eq $OURDOMAIN) {
	$project = Project->Lookup($hrn->id());
    }
    else {
	#
	# We got a project URN but we need to lookup using the SA urn.
	#
	my $purn = GeniHRN::Generate($hrn->authority(), "authority", "sa");
	$project = Project->LookupNonLocal($purn);
    }
    return GeniResponse->MalformedArgsResponse("No such project")
	if (!$project);

    my $reservation = Reservation->Lookup($idx);
    return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED)
	if (!defined($reservation));

    return GeniResponse->Create(GENIRESPONSE_FORBIDDEN)
	if ($reservation->pid() ne $project->pid());
    
    $reservation->Cancel() == 0
	or GeniResponse->Create(GENIRESPONSE_ERROR);
    
    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
}

#
# Map a project credential to local user/project.
#
sub Credential2UserProject($)
{
    my ($credentials) = @_;

    my ($credential,$speaksfor) = GeniStd::CheckCredentials($credentials);
    return $credential
	if (GeniResponse::IsResponse($credential));

    return GeniResponse->MalformedArgsResponse("Not a project/user credential")
	if ($credential->target_urn()->type() ne "project" &&
	    $credential->target_urn()->type() ne "user");

    #
    # This will create a local user if it does not exist.
    #
    my $geniuser = GeniCM::CreateUserFromCertificate($credential);
    return $geniuser
	if (GeniResponse::IsResponse($geniuser));
    return ($geniuser)
	if ($credential->target_urn()->type() eq "user");	
    
    #
    # This will create a local project if it does not exist. 
    #
    my $group =
	GeniUtil::GetHoldingProject($credential->target_urn(), $geniuser, 1);
    return $group
	if (GeniResponse::IsResponse($group));
    
    return ($geniuser, $group->GetProject());
}

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