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