Revision 7b1aad71104f44c99129f70177d23ccfd98eea52 authored by David Morton on 26 July 2013, 18:27:30 UTC, committed by David Morton on 26 July 2013, 18:27:30 UTC
1 parent f2bce79
Raw File
Snapshot.pm
package Snapshot;

use strict;
use warnings;
use File::Path qw(rmtree);
use File::Slurp qw();
use File::Temp qw();
use File::Copy qw(move);

BEGIN {
    require Cwd;
    require File::Basename;
    my $lib_dir = Cwd::abs_path(File::Basename::dirname(__FILE__) . '/../lib/');
    unless (grep { $lib_dir eq Cwd::abs_path($_) } @INC) {
        push @INC, $lib_dir;
    }
}

use Library qw();
use Defaults qw();

sub new {
    my $class = shift;
    my (%params) = @_;
    my $snapshot_dir = delete $params{snapshot_dir} || die;
    my $submodules = delete $params{submodules};
    my $overwrite = delete $params{overwrite};

    if (my @params_keys = keys %params) {
        die "Invalid params passed to Snapshot->new: '" . join(', ', @params_keys) . "'\n";
    }

    my $self = {
        snapshot_dir => $snapshot_dir,
        submodules => $submodules,
        overwrite => $overwrite,
    };

    bless $self, $class;
    return $self;
}

sub open {
    my $class = shift;
    my $snapshot_dir = shift;
    return $class->new(snapshot_dir => $snapshot_dir);
}

sub create {
    my $class = shift;

    my $self;
    if ( ref $class ) {
        $self = $class;
    } else {
        $self = $class->new(@_);
    }

    my $snapshot_dir = $self->{snapshot_dir};
    my $tmp_snapshot_dir = "$snapshot_dir.tmp";
    $self->{snapshot_dir} = $tmp_snapshot_dir;

    if ( -d $snapshot_dir ) {
        if ($self->{overwrite}) {
            unless ( system("rm -rf $snapshot_dir") == 0) {
                die "Error: failed to remove $snapshot_dir.\n";
            }
        } else {
            die "Error: $snapshot_dir already exists and overwrite was not specified.\n";
        }
    }


    $self->{snapshot_dir} = $tmp_snapshot_dir;
    my @submodules = @{ $self->{submodules} };

    for my $submodule (@submodules) {
        unless ( -d $submodule ) {
            die "Error: $submodule directory not found.\n";
        }
    }

    $self->create_snapshot_dir;

    $self->post_create_cleanup;

    $self->update_tab_completion;

    $self->{snapshot_dir} = $snapshot_dir;
    print "Moving to final location...";
    unless (move($tmp_snapshot_dir, $snapshot_dir)) {
        print "ERROR: move: $!\n";
        print "Removing (corrupt) snapshot_dir: $snapshot_dir\n";
        rmtree($snapshot_dir);
        print "Removing tmp_snapshot_dir: $tmp_snapshot_dir\n";
        rmtree($tmp_snapshot_dir);
        print "Aborting.\n";
        exit 1;
    }

    print "Removing tmp_snapshot_dir: $tmp_snapshot_dir\n";
    rmtree($tmp_snapshot_dir);

    return $self;
}

sub create_snapshot_dir {
    my $self = shift;
    my $snapshot_dir = $self->{snapshot_dir};
    my @submodules = @{ $self->{submodules} };

    unless ( system("mkdir -p $snapshot_dir") == 0 ) {
        die "Error: failed to create directory: '$snapshot_dir'.\n";
    }

    for my $dir ('.', @submodules) {
        for my $subdir ('bin', 'sbin', 'lib', 'etc') {
            next unless (-d "$dir/$subdir");
            unless ( system("rsync -rltoD --exclude .git --exclude *.t $dir/$subdir/ $snapshot_dir/$subdir/") == 0 ) {
                die "Error: failed to rsync $dir/$subdir/.\n";
            }
        }
    }

    wait_for_path($snapshot_dir); # $snapshot_dir doesn't instantly show up on other NFS shares...
    my @dump_files = qx[find $snapshot_dir -iname '*sqlite3-dump'];
    push @dump_files, qx[find $snapshot_dir -iname '*sqlite3n-dump'];
    for my $sqlite_dump (@dump_files) {
        chomp $sqlite_dump;
        (my $sqlite_db = $sqlite_dump) =~ s/-dump//;
        if (-e $sqlite_db) {
            print "SQLite DB $sqlite_db already exists, skipping\n";
        } else {
            print "Updating SQLite DB ($sqlite_db) from dump\n";
            my $sqlite_path = $ENV{SQLITE_PATH} || 'sqlite3';
            system("$sqlite_path $sqlite_db < $sqlite_dump");
        }
        unless ( wait_for_path($sqlite_db) ) {
            die "Failed to reconstitute $sqlite_dump as $sqlite_db!\n";
        }
    }

    # Something to do with generating InlineConfig*. Figure out a better/faster way to generate it.
    my $cmd = "cd $snapshot_dir/lib/perl/Genome && genome-perl -S ur test use";
    my $exit_code = system($cmd);
    unless ($exit_code == 0) {
        die "Error: failed to use all classes!";
    }

    return 1;
}

sub post_create_cleanup {
    my $self = shift;
    my $snapshot_dir = $self->{snapshot_dir};

    my @paths = glob("$snapshot_dir/lib/*");
    @paths = grep { $_ !~ /\/lib\/(?:perl|java)/ } @paths;
    for my $path (@paths) {
        (my $new_path = $path) =~ s/$snapshot_dir\/lib\//$snapshot_dir\/lib\/perl\//;
        unless ( system("mv $path $new_path") == 0 ) {
            die "Error: failed to move $path to $new_path.\n";
        }
    }

    for my $ext ('pl', 'sh') {
        my @files = glob("$snapshot_dir/bin/*.$ext");
        my @exceptions = ('genome-re\.pl$');
        for my $file (@files) {
            next if grep { $file =~ /$_/ } @exceptions;
            (my $new_file = $file) =~ s/\.$ext$//;
            rename($file, $new_file);
        }
    }

    # Only allow bins that have been "whitelisted" because we once accidentally upgraded the whole center's perl.
    my @bins = glob("$snapshot_dir/bin/*");
    # Intentionally leaving off $ so it allows genome*, gmt*, etc.
    my @bad_bins = grep { $_ !~ /$snapshot_dir\/bin\/(genome|gmt|ur|workflow|annotate-log|filter_bqm_for_errors|getopt_complete)/ } @bins;
    if (@bad_bins) {
        system('rm', '-f', @bad_bins);
    }

    system("file $snapshot_dir/bin/* | grep text | cut -d : -f 1 | xargs reshebang");

    return 1;
}

sub update_tab_completion {
    my $self = shift;
    my $snapshot_dir = $self->{snapshot_dir};

    system("cd $snapshot_dir/lib/perl && ur update tab-completion-spec Genome\:\:Command");
    system("cd $snapshot_dir/lib/perl && ur update tab-completion-spec Genome\:\:Model\:\:Tools");
    system("cd $snapshot_dir/lib/perl && ur update tab-completion-spec UR\:\:Namespace\:\:Command");
    system("cd $snapshot_dir/lib/perl && ur update tab-completion-spec Workflow\:\:Command");

    return 1;
}

sub move_to {
    my $self = shift;
    my $move_to = shift || die;
    my $snapshot_dir = $self->{snapshot_dir};

    (my $snapshot_name = $snapshot_dir) =~ s/.*\///;

    my $dest_dir;
    if ( $move_to =~ /old/ ) {
        $dest_dir = Defaults::OLD_PATH() . "/$snapshot_name";
    } else {
        die "Error: tried to move a directory to unrecognized location; $move_to does not match unstable/tested/stable.\n";
    }


    my $is_symlinked = 0;
    for my $symlink (Defaults::CURRENT_USER(), Defaults::CURRENT_WEB(), Defaults::CURRENT_PIPELINE()) {
        $is_symlinked = 1 if ( readlink($symlink) =~ /^$snapshot_dir\/?$/ );
    }
    if ($is_symlinked) {
        execute_or_die("rsync -rltoD $snapshot_dir/ $dest_dir/");
        for my $symlink (Defaults::CURRENT_USER(), Defaults::CURRENT_WEB(), Defaults::CURRENT_PIPELINE()) {
            if ( readlink($symlink) =~ /^$snapshot_dir\/?$/ ) {
                print "Updating symlink ($symlink) since we are moving the snapshot.\n";
                execute_or_die("ln -sf $dest_dir $symlink-new");
                execute_or_die("mv -Tf $symlink-new $symlink");
            }
        }
        execute_or_die("rm -rf $snapshot_dir/");
    }
    else {
        print "moving $snapshot_name to $dest_dir...\n";
        execute_or_die("mv -n $snapshot_dir $dest_dir/");
        if (-d $snapshot_dir) {
            die "ERROR: old directory still exists: $snapshot_dir\n"
        }
    }

    $self->{snapshot_dir} = $dest_dir;

    return 1;
}

sub wait_for_path {
    my $path = shift || die;
    my $max_time = shift || 300;
    my $count = 0;
    while ( not -e $path && $count <= $max_time) {
        sleep(1);
        $count++;
    }

    return ( -e $path );
}

sub execute_or_die {
    my $cmd = shift;

    unless ( $cmd ) {
        die "No command specified to execute_or_die\n";
    }

    my $exit = system($cmd);
    die "Error: exit code $? for '$cmd'" if $?;

    # print "Command exited $exit: $cmd\n";

    my $rv = 0;
    $rv = 1 if ( $exit == 0 );

    return $rv;
}

sub find_snapshot {
    my $build_name = shift;
    $build_name =~ s/genome-genome/genome/;
    my $snapshot_path;

    if ( -d Defaults::SNAPSHOTS_PATH() . "/$build_name" ) {
        $snapshot_path = Defaults::SNAPSHOTS_PATH() . "/$build_name";
    } elsif ( -d Defaults::CUSTOM_PATH() . "/$build_name" ) {
        $snapshot_path = Defaults::CUSTOM_PATH() . "/$build_name";
    } elsif ( -d Defaults::OLD_PATH() . "/$build_name") {
        $snapshot_path = Defaults::OLD_PATH() . "/$build_name";
    } else {
        die "Unable to find $build_name in " . Defaults::BASE_DIR() . "/snapshots/{,custom,old}\n";
    }

    return $snapshot_path;
}


1;

back to top