File Coverage

blib/script/narada-install

Criterion	Covered	Total	%
statement	146	155	94.1
branch	50	54	92.5
condition	24	27	88.8
subroutine	24	25	96.0
pod			n/a
total	244	261	93.4

#!/usr/bin/env perl
use 5.010001;
use warnings;
use strict;
use utf8;

our $VERSION = 'v2.3.7';

use FindBin;
use lib "$FindBin::Bin/../lib/perl5";
use Path::Tiny;
use Narada;
use Narada::Lock qw( exclusive_lock unlock_new shared_lock unlock );
use App::migrate;
use Getopt::Long qw( GetOptionsFromArray );

use constant INITIAL_VERSION    => '0.0.0';
use constant FULL_BACKUP        => path('.backup/full.tar');
use constant USAGE              => <<'EOUSAGE';
Usage:
    narada-install [--allow-downgrade|-D] [--allow-restore|-R] [-f ]
    narada-install [-f ] --path|-p    ...
    narada-install --check|-c
    narada-install --help|-h
EOUSAGE

my $Last_backup;        # OPTIMIZATION delay copying last backup to drop exclusive_lock faster


main(@ARGV) if !caller;


sub err { die "narada-install: @_\n" };

sub main {
        ## no critic (RequireCarping)
        my ($allow_downgrade, $allow_restore, @files) = (0, 0);
        my ($is_path, $check, $is_help);
        my ($prev_version, $next_version, $path);
        GetOptionsFromArray(\@_,
                'D|allow-downgrade'     => \$allow_downgrade,
                'R|allow-restore'       => \$allow_restore,
                'f=s@'                  => \@files,
                'p|path'                => \$is_path,
                'c|check=s'             => \$check,
                'h|help'                => \$is_help,
        ) or die USAGE;
        if ($is_help) {
                print USAGE;
                return;
        }
        if (defined $check) {
                die USAGE if @_ || $is_path || $allow_downgrade || $allow_restore || @files;
                say "Checking $check";
                App::migrate->new->load($check);
                return;
        }
        if ($is_path) {
                die USAGE if @_ <= 2;
                $path           = [@_];
                $prev_version   = $path->[0];
                $next_version   = $path->[-1];
                $allow_downgrade= 1;
                $allow_restore  = 1;
        }
        else {
                die USAGE if @_ != 1;
                $next_version = $_[0];
                $prev_version = INITIAL_VERSION;
                if (path(q{.})->children(qr/\A(?![.]release\z|[.]backup\z|[.]lock)/ms)) {
                        Narada::detect('narada');
                        ($prev_version) = path('VERSION')->lines({chomp=>1});
                }
        }
        if ($next_version eq $prev_version) {
                return;
        }

        my $migrate = load($prev_version, $next_version, @files);
        $path ||= get_path($migrate, $prev_version, $next_version);
        check_path($migrate, $path, $allow_downgrade, $allow_restore);
        migrate($migrate, $path);

        return;
}

sub load {
        my ($prev_version, $next_version, @files) = @_;
        my $migrate = App::migrate->new;
        if ($next_version ne INITIAL_VERSION) {
                push @files, ".release/$next_version.migrate";
        }
        if (-f ".release/$prev_version.migrate") {
                push @files, ".release/$prev_version.migrate";
        }
        for (@files) {
                say "Loading $_";
                $migrate->load($_);
        }
        return $migrate;
}

sub get_path {
        my ($migrate, $prev_version, $next_version) = @_;
        my @paths = $migrate->find_paths($prev_version, $next_version);
        if (0 == @paths) {
                err "Unable to find migration path from $prev_version to $next_version";
        }
        elsif (1 != @paths) {
                err join "\n",
                        'Found more than one upgrade path, run one of these commands to choose a path:',
                        map {"\tnarada-install --path @{$_}"} @paths;
        }
        return $paths[0];
}

sub check_path {
        my ($migrate, $path, $allow_downgrade, $allow_restore) = @_;
        if ($allow_restore) {
                $allow_downgrade = 1;
        }
        for my $step ($migrate->get_steps($path)) {
                my $t = $step->{type};
                my $is_down = $t eq 'downgrade' || $t eq 'after_downgrade';
                err 'Downgrade required, use --allow-downgrade to continue'
                        if $is_down && !$allow_downgrade;
                err 'Restore from backup required, use --allow-restore to continue'
                        if $t eq 'RESTORE' && !$allow_restore;
                if ($t eq 'RESTORE') {
                        my $f = path(".backup/full-$step->{next_version}.tar");
                        err "Required backup not found: $f" if !$f->is_file;
                }
        }
        return;
}

sub migrate {
        my ($migrate, $path) = @_;

        say 'Acquire exclusive lock ...';
        exclusive_lock();
        {
                local $ENV{NARADA_SKIP_LOCK} = 1;
                $Last_backup = undef;   # tests may call main() many times
                $migrate->on(BACKUP     => \&_backup)
                        ->on(RESTORE    => \&_restore)
                        ->on(VERSION    => \&_version)
                        ->on(error      => \&_error)
                        ->run($path);
        }
        unlock_new();

        shared_lock();
        if ($Last_backup && !FULL_BACKUP->exists) {
                path($Last_backup)->copy(FULL_BACKUP);
        }
        unlock();

        return;
}

sub ask {
        my ($msg, $match) = @_;
        print $msg;
        # TODO try IO::Prompter
        ## no critic (ProhibitExplicitStdin)
        while () {
                chomp;
                return $_ if /$match/ms;
                print $msg;
        }
        die "Interrupted by EOF\n";
}

sub _backup {
        my ($step) = @_;
        if ($step->{version} ne INITIAL_VERSION) {
                if ($Last_backup) {
                        path($Last_backup)->copy(FULL_BACKUP);
                }
                my $file = ".backup/full-$step->{version}.tar";
                say "Backuping to $file";
                system('narada-backup') == 0 or die "BACKUP failed\n";
                $Last_backup = $file;
                FULL_BACKUP->move($Last_backup);
        }
        return;
}

sub _restore {
        my ($step) = @_;
        my $file = ".backup/full-$step->{version}.tar";
        say "Restoring from $file";
        system('narada-restore', $file) == 0 or die "RESTORE failed\n";
        return;
}

sub _version {
        my ($step) = @_;
        say "Migration to $step->{version} completed";
        if ($step->{version} eq INITIAL_VERSION) {
                path('VERSION')->remove;
        }
        else {
                path('VERSION')->spew_utf8("$step->{version}\n");
        }
        return;
}

sub _error {
        say q{};
        say 'YOU NEED TO MANUALLY FIX THIS ISSUE RIGHT NOW';
        my $prompt
                = "Please choose what to do:\n"
                . "  shell    - run $ENV{SHELL} (exit from it to return to this menu)\n"
                . "  continue - continue migration (use if you have fixed this issue)\n"
                . "  restore  - interrupt migration and RESTORE previous version from backup\n"
                . 'Enter action [shell]: '
                ;
        while (1) {
                my $ans = lc ask($prompt, qr/\A(?:shell|continue|restore|\s*)\z/msi);
                if ($ans eq 'restore') {
                        die "Migration failed\n";
                }
                elsif ($ans eq 'continue') {
                        last;
                }
                else {
                        system $ENV{SHELL};
                }
        }
        return;
}


1; # Magic true value required at end of module
__END__