Commit 1957199f authored by Leigh B. Stoller's avatar Leigh B. Stoller
Browse files

Ongoing cleanup of the code and conversion to perl objects. Its a

thankless job but someone has to do it. I'm expecting to finish by the
time Bush 43 leaves office.
parent cd24a8fb
#!/usr/bin/perl -wT #!/usr/bin/perl -wT
# #
# EMULAB-COPYRIGHT # EMULAB-COPYRIGHT
# Copyright (c) 2005, 2006 University of Utah and the Flux Group. # Copyright (c) 2005, 2006, 2007 University of Utah and the Flux Group.
# All rights reserved. # All rights reserved.
# #
use strict;
use English; use English;
use Getopt::Std; use Getopt::Std;
...@@ -49,6 +50,7 @@ sub fatal($); ...@@ -49,6 +50,7 @@ sub fatal($);
use lib "@prefix@/lib"; use lib "@prefix@/lib";
use libdb; use libdb;
use libtestbed; use libtestbed;
use Project;
# #
# We don't want to run this script unless its the real version. # We don't want to run this script unless its the real version.
...@@ -79,7 +81,7 @@ if (! $BUGDBSUPPORT) { ...@@ -79,7 +81,7 @@ if (! $BUGDBSUPPORT) {
# Parse command arguments. Once we return from getopts, all that should be # Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments. # left are the required arguments.
# #
%options = (); my %options = ();
if (! getopts($optlist, \%options)) { if (! getopts($optlist, \%options)) {
usage(); usage();
} }
...@@ -89,22 +91,11 @@ if (defined($options{"d"})) { ...@@ -89,22 +91,11 @@ if (defined($options{"d"})) {
if (@ARGV != 1) { if (@ARGV != 1) {
usage(); usage();
} }
my $pid = $ARGV[0]; my $project = Project->Lookup($ARGV[0]);
if (!defined($project)) {
# fatal("No such project $ARGV[0]!");
# Untaint args.
#
if ($pid =~ /^([-\w]+)$/) {
$pid = $1;
}
else {
die("Bad data in pid: $pid");
}
# Valid project?
if (! ProjLeader($pid)) {
fatal("No such project $pid!");
} }
my $pid = $project->pid();
# #
# This script always does the right thing, so no permission checks. # This script always does the right thing, so no permission checks.
......
#!/usr/bin/perl -wT #!/usr/bin/perl -wT
# #
# EMULAB-COPYRIGHT # EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group. # Copyright (c) 2005-2007 University of Utah and the Flux Group.
# All rights reserved. # All rights reserved.
# #
use English; use English;
...@@ -141,14 +141,6 @@ else { ...@@ -141,14 +141,6 @@ else {
die("Bad user name: $user."); die("Bad user name: $user.");
} }
#
# Get user DB uid.
#
#if (! UNIX2DBUID($UID, \$dbuid)) {
# die("*** $0:\n".
# " You do not exist in the Emulab Database!\n");
#}
# #
# Permission checks. Do this later. # Permission checks. Do this later.
# #
......
#!/usr/bin/perl -wT #!/usr/bin/perl -wT
# #
# EMULAB-COPYRIGHT # EMULAB-COPYRIGHT
# Copyright (c) 2005, 2006 University of Utah and the Flux Group. # Copyright (c) 2005, 2006, 2007 University of Utah and the Flux Group.
# All rights reserved. # All rights reserved.
# #
use English; use English;
...@@ -22,7 +22,6 @@ sub usage() ...@@ -22,7 +22,6 @@ sub usage()
my $optlist = "daur"; my $optlist = "daur";
my $debug = 0; my $debug = 0;
my $reconfig = 0; my $reconfig = 0;
my $dbuid;
my $listtype; my $listtype;
my $listname; my $listname;
my $listowner; my $listowner;
...@@ -62,6 +61,7 @@ $| = 1; ...@@ -62,6 +61,7 @@ $| = 1;
use lib "@prefix@/lib"; use lib "@prefix@/lib";
use libdb; use libdb;
use libtestbed; use libtestbed;
use User;
# #
# We don't want to run this script unless its the real version. # We don't want to run this script unless its the real version.
...@@ -89,12 +89,13 @@ if (! $MAILMANSUPPORT) { ...@@ -89,12 +89,13 @@ if (! $MAILMANSUPPORT) {
} }
# #
# Get user DB uid. # Verify user and get his DB uid and other info for later.
# #
if (! UNIX2DBUID($UID, \$dbuid)) { my $this_user = User->ThisUser();
die("*** $0:\n". if (! defined($this_user)) {
" You do not exist in the Emulab Database!\n"); tbdie("You ($UID) do not exist!");
} }
my $user_uid = $this_user->uid();
# #
# Parse command arguments. Once we return from getopts, all that should be # Parse command arguments. Once we return from getopts, all that should be
...@@ -203,7 +204,7 @@ if ($CONTROL ne $BOSSNODE) { ...@@ -203,7 +204,7 @@ if ($CONTROL ne $BOSSNODE) {
} }
if (! $reconfig) { if (! $reconfig) {
SENDMAIL($TBAUDIT, "Mailman list created", SENDMAIL($TBAUDIT, "Mailman list created",
"Mailman list '$listname' has been created by '$dbuid'", "Mailman list '$listname' has been created by '$user_uid'",
$TBOPS); $TBOPS);
} }
} }
......
#!/usr/bin/perl -wT #!/usr/bin/perl -wT
# #
# EMULAB-COPYRIGHT # EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group. # Copyright (c) 2005-2007 University of Utah and the Flux Group.
# All rights reserved. # All rights reserved.
# #
use English; use English;
...@@ -17,7 +17,6 @@ sub usage() ...@@ -17,7 +17,6 @@ sub usage()
} }
my $optlist = "dau"; my $optlist = "dau";
my $debug = 0; my $debug = 0;
my $dbuid;
my $listtype; my $listtype;
my $listname; my $listname;
my $listowner; my $listowner;
...@@ -57,6 +56,7 @@ $| = 1; ...@@ -57,6 +56,7 @@ $| = 1;
use lib "@prefix@/lib"; use lib "@prefix@/lib";
use libdb; use libdb;
use libtestbed; use libtestbed;
use User;
# #
# We don't want to run this script unless its the real version. # We don't want to run this script unless its the real version.
...@@ -84,12 +84,13 @@ if (! $MAILMANSUPPORT) { ...@@ -84,12 +84,13 @@ if (! $MAILMANSUPPORT) {
} }
# #
# Get user DB uid. # Verify user and get his DB uid and other info for later.
# #
if (! UNIX2DBUID($UID, \$dbuid)) { my $this_user = User->ThisUser();
die("*** $0:\n". if (! defined($this_user)) {
" You do not exist in the Emulab Database!\n"); tbdie("You ($UID) do not exist!");
} }
my $user_uid = $this_user->uid();
# #
# Parse command arguments. Once we return from getopts, all that should be # Parse command arguments. Once we return from getopts, all that should be
...@@ -142,7 +143,7 @@ if ($CONTROL ne $BOSSNODE) { ...@@ -142,7 +143,7 @@ if ($CONTROL ne $BOSSNODE) {
} }
SENDMAIL($TBAUDIT, "Mailman list deleted", SENDMAIL($TBAUDIT, "Mailman list deleted",
"Mailman list '$listname' has been deleted by '$dbuid'", "Mailman list '$listname' has been deleted by '$user_uid'",
$TBOPS); $TBOPS);
} }
exit(0); exit(0);
......
#!/usr/bin/perl -wT #!/usr/bin/perl -wT
# #
# EMULAB-COPYRIGHT # EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group. # Copyright (c) 2005, 2007 University of Utah and the Flux Group.
# All rights reserved. # All rights reserved.
# #
use English; use English;
...@@ -19,7 +19,6 @@ sub usage() ...@@ -19,7 +19,6 @@ sub usage()
} }
my $optlist = "dau"; my $optlist = "dau";
my $debug = 0; my $debug = 0;
my $dbuid;
my $listtype; my $listtype;
my $listname; my $listname;
my $listowner; my $listowner;
...@@ -59,6 +58,7 @@ $| = 1; ...@@ -59,6 +58,7 @@ $| = 1;
use lib "@prefix@/lib"; use lib "@prefix@/lib";
use libdb; use libdb;
use libtestbed; use libtestbed;
use User;
# #
# We don't want to run this script unless its the real version. # We don't want to run this script unless its the real version.
...@@ -86,12 +86,13 @@ if (! $MAILMANSUPPORT) { ...@@ -86,12 +86,13 @@ if (! $MAILMANSUPPORT) {
} }
# #
# Get user DB uid. # Verify user and get his DB uid and other info for later.
# #
if (! UNIX2DBUID($UID, \$dbuid)) { my $this_user = User->ThisUser();
die("*** $0:\n". if (! defined($this_user)) {
" You do not exist in the Emulab Database!\n"); tbdie("You ($UID) do not exist!");
} }
my $user_uid = $this_user->uid();
# #
# Parse command arguments. Once we return from getopts, all that should be # Parse command arguments. Once we return from getopts, all that should be
...@@ -187,7 +188,7 @@ if ($CONTROL ne $BOSSNODE) { ...@@ -187,7 +188,7 @@ if ($CONTROL ne $BOSSNODE) {
SENDMAIL($TBAUDIT, "Mailman list password changed", SENDMAIL($TBAUDIT, "Mailman list password changed",
"The mailman list password for list '$listname' has been ". "The mailman list password for list '$listname' has been ".
"changed by '$dbuid'", "changed by '$user_uid'",
$TBOPS); $TBOPS);
} }
exit(0); exit(0);
......
...@@ -34,6 +34,8 @@ use vars qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPIN ...@@ -34,6 +34,8 @@ use vars qw($EXPT_PRELOAD $EXPT_START $EXPT_SWAPIN
my $TB = "@prefix@"; my $TB = "@prefix@";
my $BOSSNODE = "@BOSSNODE@"; my $BOSSNODE = "@BOSSNODE@";
my $CONTROL = "@USERNODE@"; my $CONTROL = "@USERNODE@";
my $TBOPS = "@TBOPSEMAIL@";
my $PROJROOT = "@PROJROOT_DIR@";
my $EVENTSYS = @EVENTSYS@; my $EVENTSYS = @EVENTSYS@;
my $STAMPS = @STAMPS@; my $STAMPS = @STAMPS@;
my $TEVC = "$TB/bin/tevc"; my $TEVC = "$TB/bin/tevc";
...@@ -218,6 +220,8 @@ sub swapper_idx($) { return field($_[0], 'swapper_idx');} ...@@ -218,6 +220,8 @@ sub swapper_idx($) { return field($_[0], 'swapper_idx');}
sub use_ipassign($) { return field($_[0], 'use_ipassign');} sub use_ipassign($) { return field($_[0], 'use_ipassign');}
sub ipassign_args($) { return field($_[0], 'ipassign_args');} sub ipassign_args($) { return field($_[0], 'ipassign_args');}
sub security_level($) { return field($_[0], 'security_level');} sub security_level($) { return field($_[0], 'security_level');}
sub linktest_pid($) { return field($_[0], 'linktest_pid');}
sub linktest_level($) { return field($_[0], 'linktest_level');}
sub archive_idx($) { return stats($_[0], 'archive_idx'); } sub archive_idx($) { return stats($_[0], 'archive_idx'); }
sub swapin_count($) { return stats($_[0], 'swapin_count'); } sub swapin_count($) { return stats($_[0], 'swapin_count'); }
sub destroyed($) { return stats($_[0], 'destroyed'); } sub destroyed($) { return stats($_[0], 'destroyed'); }
...@@ -260,6 +264,35 @@ sub AllActive($) ...@@ -260,6 +264,35 @@ sub AllActive($)
return @result; return @result;
} }
#
# All experiments for a particular user. Class method.
#
sub UserExperimentList($$$)
{
my ($class, $user, $plist) = @_;
my @result = ();
my $uid_idx = $user->uid_idx();
my $query_result =
DBQueryWarn("select idx from experiments ".
"where creator_idx='$uid_idx' or swapper_idx='$uid_idx'");
return -1
if (! $query_result);
while (my ($idx) = $query_result->fetchrow_array()) {
my $experiment = Experiment->Lookup($idx);
if (!defined($experiment)) {
print STDERR "Experiment::UserExperimentList: ".
"No object for $idx!\n";
return -1;
}
push(@result, $experiment);
}
@$plist = @result;
return 0;
}
# This is needed a lot. # This is needed a lot.
sub unix_gid($) sub unix_gid($)
{ {
...@@ -527,11 +560,44 @@ sub Delete($;$) ...@@ -527,11 +560,44 @@ sub Delete($;$)
my $pid = $self->pid(); my $pid = $self->pid();
my $eid = $self->eid(); my $eid = $self->eid();
my $exptidx = $self->idx(); my $exptidx = $self->idx();
my $workdir = $self->WorkDir();
my $userdir = $self->UserDir();
$purge = 0 $purge = 0
if (!defined($purge)); if (!defined($purge));
TBExptDestroy($pid, $eid); #
# Try to remove experiment directory. We allow for it not being there
# cause we often run the tb programs directly. We also allow for not
# having permission, in the case that an admin type is running this,
# in which case it won't be allowed cause of directory permissions. Thats
# okay since admin types should rarely end experiments in other projects.
#
print "Removing experiment directories ... \n";
if (defined($userdir) && system("/bin/rm -rf $userdir")) {
print "*** WARNING: Not able to remove $userdir\n";
print " Someone will need to do this by hand.\n";
# NFS errors usually the result. Sometimes its cause there is
# someone in the directory, so its being held open.
libtestbed::SENDMAIL($TBOPS,
"Experiment::Delete: Could not remove directory",
"Could not remove $userdir.\n".
"Someone will need to do this by hand.\n");
}
if (system("/bin/rm -rf $workdir")) {
print "*** WARNING: Not able to remove $workdir\n";
print " Someone will need to do this by hand.\n";
}
# Yuck.
if ($pid ne $self->gid()) {
my $eidlink = "$PROJROOT/$pid/exp/$eid";
unlink($eidlink)
if (-l $eidlink);
}
libArchive::TBDeleteExperimentArchive($pid, $eid);
DBQueryWarn("DELETE from experiments ".
"WHERE eid='$eid' and pid='$pid'");
# #
# Mark experiment destroyed. This is a backup to End() below. # Mark experiment destroyed. This is a backup to End() below.
...@@ -900,11 +966,42 @@ sub AccessCheck($$$) ...@@ -900,11 +966,42 @@ sub AccessCheck($$$)
return -1 return -1
if (! ref($self)); if (! ref($self));
my $uid = (ref($user) ? $user->uid() : $user); if ($access_type < TB_EXPT_MIN ||
my $pid = $self->pid(); $access_type > TB_EXPT_MAX) {
my $eid = $self->eid(); die("*** Invalid access type: $access_type!");
}
# Admins do whatever they want.
return 1
if ($user->IsAdmin());
my $group = $self->GetGroup();
return 0
if (!defined($group));
my $project = $self->GetProject();
return 0
if (!defined($project));
#
# An experiment may be destroyed by the experiment creator or the
# project/group leader.
#
my $mintrust;
if ($access_type == TB_EXPT_READINFO) {
$mintrust = PROJMEMBERTRUST_USER;
}
else {
$mintrust = PROJMEMBERTRUST_LOCALROOT;
}
return TBExptAccessCheck($uid, $pid, $eid, $access_type); #
# Either proper permission in the group, or group_root in the project.
# This lets group_roots muck with other people's experiments, including
# those in groups they do not belong to.
#
return TBMinTrust($group->Trust($user), $mintrust) ||
TBMinTrust($project->Trust($user), PROJMEMBERTRUST_GROUPROOT);
} }
# #
...@@ -938,7 +1035,7 @@ sub GetProject($) ...@@ -938,7 +1035,7 @@ sub GetProject($)
my ($self) = @_; my ($self) = @_;
# Must be a real reference. # Must be a real reference.
return -1 return undef
if (! ref($self)); if (! ref($self));
my $project = Project->Lookup($self->pid_idx()); my $project = Project->Lookup($self->pid_idx());
...@@ -958,7 +1055,7 @@ sub GetGroup($) ...@@ -958,7 +1055,7 @@ sub GetGroup($)
my ($self) = @_; my ($self) = @_;
# Must be a real reference. # Must be a real reference.
return -1 return undef
if (! ref($self)); if (! ref($self));
my $group = Group->Lookup($self->gid_idx()); my $group = Group->Lookup($self->gid_idx());
...@@ -1292,6 +1389,27 @@ sub SetLogFile($$) ...@@ -1292,6 +1389,27 @@ sub SetLogFile($$)
return 0; return 0;
} }
#
# Get the experiment logfile.
#
sub GetLogFile($$$)
{
my ($self, $lognamep, $isopenp) = @_;
# Must be a real reference.
return -1
if (! ref($self));
my $pid = $self->pid();
my $eid = $self->eid();
$$lognamep = undef;
TBExptGetLogFile($pid, $eid, $lognamep, $isopenp)
or return -1;
return 0;
}
# #
# Mark the log as open so that the spew keeps looking for more output. # Mark the log as open so that the spew keeps looking for more output.
# #
...@@ -1602,6 +1720,9 @@ sub PostSwap($$$$) ...@@ -1602,6 +1720,9 @@ sub PostSwap($$$$)
return -1 return -1
if (! ref($self)); if (! ref($self));
$flags = 0
if (!defined($flags));
my $exptidx = $self->idx(); my $exptidx = $self->idx();
my $rsrcidx = $self->rsrcidx(); my $rsrcidx = $self->rsrcidx();
my $lastrsrc = $self->lastrsrc(); my $lastrsrc = $self->lastrsrc();
...@@ -1622,11 +1743,11 @@ sub PostSwap($$$$) ...@@ -1622,11 +1743,11 @@ sub PostSwap($$$$)
my $duration = 0; my $duration = 0;
my $prev_uid_idx = 0; my $prev_uid_idx = 0;
my $prev_swapper = $swapper; my $prev_swapper = $swapper;
my $query_result;
if ($which eq $EXPT_SWAPOUT || if ($which eq $EXPT_SWAPOUT ||
($which eq $EXPT_SWAPMOD && ($which eq $EXPT_SWAPMOD &&
$self->state() eq libdb::EXPTSTATE_ACTIVE())) { $self->state() eq libdb::EXPTSTATE_ACTIVE())) {
my $query_result;
# #
# If this is a swapout, we use the current resource record. If this # If this is a swapout, we use the current resource record. If this
...@@ -1704,7 +1825,7 @@ sub PostSwap($$$$) ...@@ -1704,7 +1825,7 @@ sub PostSwap($$$$)
$which eq $EXPT_SWAPIN || $which eq $EXPT_SWAPIN ||
($which eq $EXPT_SWAPMOD && ($which eq $EXPT_SWAPMOD &&
$self->state() eq libdb::EXPTSTATE_ACTIVE())) { $self->state() eq libdb::EXPTSTATE_ACTIVE())) {
my $query_result = $query_result =
DBQueryWarn("select r.node_id,n.type,r.erole, ". DBQueryWarn("select r.node_id,n.type,r.erole, ".
" r.vname,n.phys_nodeid ". " r.vname,n.phys_nodeid ".
" from reserved as r ". " from reserved as r ".
...@@ -2124,7 +2245,7 @@ sub SetSwapInfo($$) ...@@ -2124,7 +2245,7 @@ sub SetSwapInfo($$)
my $pid = $self->pid(); my $pid = $self->pid();
my $eid = $self->eid(); my $eid = $self->eid();
TBSetExpSwapTime($pid, $eid); $self->SetSwapTime();
$self->SetSwapper($user); $self->SetSwapper($user);
return $self->Refresh();