Skip to content

GitLab

emulab-devel
emulab-devel
Commit 421c0edf authored by Leigh B. Stoller's avatar Leigh B. Stoller
Browse files
Options

Commit my prototype archive library. A work in progress, incomplete, 

not ready for primetime, or even late night TV.
parent 9b2c1e26
Hide whitespace changes
Inline Side-by-side
Showing with 639 additions and 0 deletions
tbsetup/libArchive.pm.in 0 → 100644
View file @ 421c0edf
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group.
# All rights reserved.
#
# XXX Need to deal with locking at some point ...
#
package libArchive;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = "Exporter";
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use English;
use File::stat;
use File::Basename;
use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday);
# Configure variables
my $TB = "@prefix@";
# XXX
my $ARCHIVEDIR = "/usr/testbed/exparchive";
my $TESTMODE = @TESTMODE@;
my $TBOPS = "@TBOPSEMAIL@";
my $ELABINELAB = @ELABINELAB@;
my $MD5 = "/sbin/md5";
my $MKDIR = "/bin/mkdir";
my $CHMOD = "/bin/chmod";
my $TAR = "/usr/bin/tar";
my $RM = "/bin/rm";
my $CVSBIN = "/usr/bin/cvs";
my $inittag = 'created';
my $debug = 1;
# Little helper and debug function.
sub mysystem($)
{
my ($command) = @_;
print STDERR "Running '$command'\n"
if ($debug);
system($command);
}
#
# Create a new archive. Returns -1 if any error. Otherwise return
# the new record index.
#
sub ArchiveCreate()
{
my $idx;
my $dir;
my $tag = $inittag;
#
# Need to create the directory for it, once we have the index.
#
my $query_result =
DBQueryWarn("insert into file_archives set ".
" idx=NULL, current_tag='created', ".
" date_created=UNIX_TIMESTAMP(now())");
return -1
if (!$query_result);
$idx = $query_result->insertid;
$dir = "$ARCHIVEDIR/$idx";
#
# Create the directory and store the absolute path into the new record.
# This should probably be a privledged operation at some point.
#
mysystem("$MKDIR $dir") == 0 or goto bad;
mysystem("$CHMOD 775 $dir") == 0 or goto bad;
DBQueryWarn("update file_archives set directory='$dir' where idx='$idx'")
or goto bad;
#
# Make two subdirs. One to hold the CVS control tree, and the other
# to hold the currently checked out version of the tree.
#
my $cvsdir = "$dir/repo";
my $root = "$dir/root";
my $temp = "$dir/tmp";
if (! mkdir("$cvsdir", 0777)) {
print STDERR "ArchiveCreate: Could not mkdir $cvsdir: $!\n";
goto bad;
}
if (! chmod(0777, "$cvsdir")) {
print STDERR "ArchiveCreate: Could not chmod directory $cvsdir: $!\n";
goto bad;
}
if (! mkdir("$root", 0777)) {
print STDERR "ArchiveCreate: Could not mkdir $root: $!\n";
goto bad;
}
if (! chmod(0777, "$root")) {
print STDERR "ArchiveCreate: Could not chmod directory $root: $!\n";
goto bad;
}
if (! mkdir("$temp", 0777)) {
print STDERR "ArchiveCreate: Could not mkdir $temp: $!\n";
goto bad;
}
if (! chmod(0777, "$temp")) {
print STDERR "ArchiveCreate: Could not chmod directory $temp: $!\n";
goto bad;
}
# Init the CVS control files.
mysystem("$CVSBIN -d $cvsdir init") == 0
or goto bad;
# Create an stub directory and import it as "root"
mysystem("cd $dir; mkdir ignore; cd ignore; ".
"$CVSBIN -d $cvsdir import -m 'Initial Revision' root root $tag")
== 0 or goto bad;
# Now check it out.
mysystem("cd $dir; $CVSBIN -d $cvsdir checkout root")
== 0 or goto bad;
# Now enter an initial tag for the tree. Nothing actually gets tagged.
DBQueryWarn("insert into archive_tags set ".
" tag='$tag', ".
" archive_idx='$idx', ".
" date_created=UNIX_TIMESTAMP(now())") or goto bad;
return $idx;
bad:
# mysystem("$RM -rf $dir")
# if (defined($dir));
DBQueryFatal("delete from file_archives where idx='$idx'")
if (defined($idx));
return -1;
}
#
# Add a file to an archive. Returns -1 if any error. Otherwise return 0.
# All this does is copy the file (and its directory structure) into the
# temporary store. Later, after all the files are in the tree, must
# commit it to the repo.
#
sub ArchiveAdd($$)
{
my ($archive_idx, $pathname) = @_;
if (! -e $pathname || ! -r $pathname) {
print STDERR "ArchiveFile: $pathname cannot be read!\n";
return -1;
}
if (! -f $pathname) {
print STDERR "ArchiveFile: $pathname must be a plain file!\n";
return -1;
}
#
# Check that the path does not contain an links to files outside
# the directory space the user is allowed to access.
#
my $realpath = `realpath $pathname`;
if ($realpath =~ /^([-\w\/\.\+\@,]+)$/) {
$realpath = $1;
}
else {
print STDERR "ArchiveFile: ".
"Bad data returned by realpath: $realpath\n";
}
#
# The file must reside in /proj, /groups, or /users.
#
if (! ($realpath =~ /^\/proj/) &&
! ($realpath =~ /^\/groups/) &&
! ($realpath =~ /^\/users/)) {
print STDERR "ArchiveFile: ".
"$realpath does not resolve to an allowed directory!\n";
return -1;
}
# Strip leading / from the pathname, and taint check it.
if ($pathname =~ /^[\/]+([-\w\/\.\+\@,]+)$/) {
$pathname = $1;
}
else {
print STDERR "ArchiveFile: Illegal characters in pathname $pathname\n";
return -1;
}
#
# See if the archive exists and if it does, get the pathname to it.
#
my $directory;
if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
print STDERR "ArchiveFile: ".
"Archive '$archive_idx' does not exist in the DB!\n";
return -1;
}
if (! -d $directory || ! -w $directory) {
print STDERR "ArchiveFile: $directory cannot be written!\n";
return -1;
}
my $cvsdir = "$directory/repo";
my $rootdir = "$directory/root";
my $tmpdir = "$directory/tmp";
#
# See if the file is already in the archive. We currently deal with
# just files; directories are gonna be a pain in the butt.
#
my $target_path = "$tmpdir/$pathname";
#
# The file should not already exist in the temporary store.
#
if (-e $target_path) {
print STDERR "ArchiveFile: ".
"$pathname already exists in archive '$archive_idx'!\n";
return -1;
}
#
# Not in the archive. Copy the file in. We use tar cause we
# want to retain the directory structure and mode bits, etc.
#
mysystem("$TAR cf - /$pathname | tar xf - -C $tmpdir");
if ($?) {
print STDERR "ArchiveFile: Could not copy in /$pathname\n";
return -1;
}
return 0;
}
#
# Commit the current contents of the temporary store to the archive.
# Returns -1 if any error. Otherwise return 0.
#
sub ArchiveCommit($;$)
{
my ($archive_idx, $newtag) = @_;
#
# See if the archive exists and if it does, get the pathname to it.
#
my $directory;
if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
print STDERR "ArchiveCommit: ".
"Archive '$archive_idx' does not exist in the DB!\n";
return -1;
}
if (! -d $directory || ! -w $directory) {
print STDERR "ArchiveFile: $directory cannot be written!\n";
return -1;
}
my $cvsdir = "$directory/repo";
my $rootdir = "$directory/root";
my $tmpdir = "$directory/tmp";
# Get the current tag for the archive.
my $archive_tag;
if (GetArchiveCurrentTag($archive_idx, \$archive_tag) < 0) {
print STDERR "ArchiveCommit: ".
"Archive '$archive_idx' does not have a current tag!\n";
return -1;
}
if (!defined($newtag)) {
my ($seconds, $microseconds) = gettimeofday();
$newtag = POSIX::strftime("T20%y%m%d-%H%M%S", localtime());
$newtag .= $microseconds;
}
my $import_tag = $newtag . "_import";
my $commit_tag = $newtag . "_commit";
if (! chdir("$tmpdir")) {
print STDERR "ArchiveCommit: ".
"Cannot chdir to $tmpdir!\n";
return -1;
}
#
# Use cvs import command. This is nice cause it handles all the
# subdirs and stuff in one shot, instead of trying to deal with
# each file and directory individually.
#
mysystem("$CVSBIN -d $cvsdir import ".
"-m 'Import new version' root root $import_tag");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not import from $tmpdir!\n";
return -1;
}
DBQueryWarn("insert into archive_tags set ".
" tag='$newtag', ".
" archive_idx='$archive_idx', ".
" date_created=UNIX_TIMESTAMP(now())") or return -1;
DBQueryWarn("update file_archives set ".
" current_tag='$newtag' ".
"where idx='$archive_idx'");
# Clean the temp dir for next phase.
mysystem("/bin/rm -rf $tmpdir/*");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not remove contents of $tmpdir!\n";
return -1;
}
#
# If this is the first commit, then we are done cause there is nothing
# to merge with.
#
return 0
if ($archive_tag eq $inittag);
#
# Need to merge. Do a fresh checkout, merging this latest tag with
# the previous tag.
#
mysystem("$CVSBIN -d $cvsdir checkout ".
"-j ${archive_tag}_import -j $import_tag root");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not checkout and merge $archive_tag with $newtag!\n";
return -1;
}
# And then commit it back to the head revision.
mysystem("$CVSBIN -d $cvsdir commit ".
"-m 'Merged ${archive_tag}_import with $import_tag'");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not commit merge back to the repository!\n";
return -1;
}
# Clean the temp dir for next phase.
mysystem("/bin/rm -rf $tmpdir/*");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not remove contents of $tmpdir!\n";
return -1;
}
# And lets tag the tree for good measure with a commit tag.
mysystem("$CVSBIN -d $cvsdir rtag $commit_tag root");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not rtag with $commit_tag!\n";
return -1;
}
# And now into the root dir to checkout a current copy.
if (! chdir("$rootdir")) {
print STDERR "ArchiveCommit: ".
"Cannot chdir to $rootdir!\n";
return -1;
}
mysystem("$CVSBIN -d $cvsdir checkout root");
if ($?) {
print STDERR "ArchiveCommit: ".
"Could not checkout head revision!\n";
return -1;
}
return 0;
}
#
# Archive the Archive, moving it into the expinfo directory.
# I intend this to be run only when an experiment is terminated.
# No need to have two copies.
#
sub ArchiveArchive($$)
{
my ($archive_idx, $dirpath) = @_;
my $target = "$dirpath/Archive";
#
# See if the archive exists and if it does, get the pathname to it.
#
my $directory;
if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
print STDERR "ArchiveCommit: ".
"Archive '$archive_idx' does not exist in the DB!\n";
return -1;
}
if (! -d $directory || ! -w $directory) {
print STDERR "ArchiveFile: $directory cannot be written!\n";
return -1;
}
if (! -e $target) {
if (! mkdir("$target", 0777)) {
print STDERR "ArchiveArchive: Could not mkdir $target: $!\n";
return -1;
}
if (! chmod(0777, "$target")) {
print STDERR "ArchiveArchive: ".
"Could not chmod directory $target: $!\n";
return -1;
}
}
#
# Tar up the whole thing and move it across.
#
mysystem("$TAR cf - -C $directory . | tar xf - -C $target");
if ($?) {
print STDERR "ArchiveArchive: Could not copy in $directory\n";
return -1;
}
return 0;
}
#
# Destroy an archive. The DB state is retained unless optional flag says
# to clean it.
#
sub ArchiveDestroy($;$)
{
my ($archive_idx, $clean) = @_;
#
# See if the archive exists and if it does, get the pathname to it.
#
my $directory;
if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
print STDERR "ArchiveDestroy: ".
"Archive '$archive_idx' does not exist in the DB!\n";
return -1;
}
if (! -d $directory || ! -w $directory) {
print STDERR "ArchiveDestroy: $directory does not exist!\n";
return 0;
}
mysystem("/bin/rm -rf $directory");
if ($?) {
print STDERR "ArchiveDestroy: ".
"Could not remove contents of $directory!\n";
return -1;
}
if (defined($clean) && $clean) {
(DBQueryWarn("delete from archive_tags ".
"where archive_idx='$archive_idx'") &&
DBQueryWarn("delete from file_archives ".
"where idx='$archive_idx'")) || return -1;
}
return 0;
}
#
# Get the directory for an archive, given its index. Returns -1 on error,
# zero otherwise.
#
sub GetArchiveDirectory($$)
{
my ($idx, $rvalp) = @_;
my $query_result =
DBQueryWarn("select directory from file_archives where idx='$idx'");
return -1
if (!$query_result || !$query_result->numrows);
my ($dir) = $query_result->fetchrow_array();
$$rvalp = $dir
if (defined($rvalp));
return 0;
}
#
# Get the current tag for an archive, given its index. Returns -1 on error,
# zero otherwise. Place tag in the return pointer.
#
sub GetArchiveCurrentTag($$)
{
my ($archive_idx, $rvalp) = @_;
my $query_result =
DBQueryWarn("select current_tag from file_archives ".
"where idx='$archive_idx'");
return -1
if (!$query_result);
my ($tag) = $query_result->fetchrow_array();
$$rvalp = $tag
if (defined($rvalp));
return 0;
}
#
# Get the archive index for an experiment. The index is kept in the historical
# experiment_stats table, not the current experiments table. That is cause
# we keep the archive and its DB info around forever with the stats.
#
sub TBExperimentArchiveIDX($$)
{
my ($pid, $eid) = @_;
my $query_result =
DBQueryWarn("select s.archive_idx from experiments as e ".
"left join experiment_stats as s on s.exptidx=e.idx ".
"where e.pid='$pid' and e.eid='$eid'");
return -1
if (!$query_result || $query_result->numrows == 0);
my ($idx) = $query_result->fetchrow_array();
return -1
if (!defined($idx));
return $idx;
}
#
# Create a new archive for an experiment. This has to update the
# experiment_stats table with the newly created archive index.
# Then we have to set the current tag for the experiment in the
# resources table for the experiment.
# Returns zero on success, -1 on failure.
#
sub TBCreateExperimentArchive($$)
{
my ($pid, $eid) = @_;
#
# Create the new archive and get back the new index.
#
my $archive_idx = ArchiveCreate();
return -1
if ($archive_idx < 0);
# Grab experiment indicies we need,
my $query_result =
DBQueryWarn("select e.idx,s.rsrcidx from experiments as e ".
"left join experiment_stats as s on e.idx=s.exptidx ".
"where e.pid='$pid' and e.eid='$eid'");
if (!$query_result || !$query_result->numrows) {
ArchiveDestroy($archive_idx, 1);
return -1;
}
my ($exptidx,$rsrcidx) = $query_result->fetchrow_array();
if (! (DBQueryWarn("update experiment_stats set ".
" archive_idx='$archive_idx' ".
"where pid='$pid' and eid='$eid' and ".
" exptidx='$exptidx'") &&
DBQueryWarn("update experiment_resources set ".
" archive_tag='$inittag' ".
"where idx='$rsrcidx'"))) {
ArchiveDestroy($archive_idx, 1);
return -1;
}
return 0;
}
#
# Add a file to an experiment archive.
#
sub TBExperimentArchiveAddFile($$$)
{
my ($pid, $eid, $pathname) = @_;
my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
return -1
if ($archive_idx < 0);
return ArchiveAdd($archive_idx, $pathname);
}
#
# Commit an experiment archive.
#
sub TBExperimentArchiveCommit($$)
{
my ($pid, $eid) = @_;
my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
return -1
if ($archive_idx < 0);
#
# Derive a tag that indicates what experiment resource entry it came from.
#
my $query_result =
DBQueryWarn("select s.rsrcidx from experiments as e ".
"left join experiment_stats as s on e.idx=s.exptidx ".
"where e.pid='$pid' and e.eid='$eid'");
if (!$query_result || !$query_result->numrows) {
return -1;
}
my ($rsrcidx) = $query_result->fetchrow_array();
my $newtag = "T$rsrcidx";
return ArchiveCommit($archive_idx, $newtag);
}
#
# Delete an experiment archive. This just deletes it from the active area.
# Its historical DB state is retained.
#
sub TBDeleteExperimentArchive($$)
{
my ($pid, $eid) = @_;
my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
return 0
if ($archive_idx < 0);
return ArchiveDestroy($archive_idx, 0);
}
#
# Destroy an experiment archive. Totally flush it from the system.
#
sub TBDestroyExperimentArchive($$)
{
my ($pid, $eid) = @_;
my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
return 0
if ($archive_idx < 0);
return ArchiveDestroy($archive_idx, 1);
}
# _Always_ make sure that this 1 is at the end of the file...
1;
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment