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

not ready for primetime, or even late night TV.

tbsetup/libArchive.pm.in

+#!/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);