File Coverage

blib/lib/App/Dest.pm

Criterion	Covered	Total	%
statement	405	422	95.9
branch	132	180	73.3
condition	48	64	75.0
subroutine	50	50	100.0
pod	22	22	100.0
total	657	738	89.0

package App::Dest;
# ABSTRACT: Deployment State Manager

use 5.016;
use exact;

use File::Basename qw( dirname basename );
use File::Copy 'copy';
use File::Copy::Recursive qw( dircopy rcopy );
use File::DirCompare ();
use File::Find 'find';
use File::Path qw( mkpath rmtree );
use IPC::Run 'run';
use Path::Tiny 'path';
use POSIX 'strftime';
use Text::Diff ();

our $VERSION = '1.36'; # VERSION

sub init {
    my $self = _new( shift, 'expect_no_root_dir' );

    mkdir('.dest') or die "Unable to create .dest directory\n";
    open( my $watch, '>', '.dest/watch' ) or die "Unable to create ~/.dest/watch file\n";

    $self = _new();

    if ( -f 'dest.watch' ) {
        open( my $watches, '<', 'dest.watch' ) or die "Unable to read dest.watch file\n";

        my @watches = map { chomp; $_ } <$watches>;

        my @errors;
        for my $watch (@watches) {
            try {
                $self->add($watch);
            }
            catch ($e) {
                push( @errors, $watch . ': ' . $e );
            }
        }

        warn
            "Created new watch list based on dest.watch file:\n" .
            join( "\n", map { '  ' . $_ } @watches ) . "\n" .
            (
                (@errors)
                    ? "With the following errors:\n" . join( '', map { '  ' . $_ } @errors )
                    : ''
            );
    }

    return 0;
}

sub add {
    my $self = _new(shift);
    die "No directory specified; usage: dest add [directory]\n" unless @_;

    my @watches = $self->_watch_list;
    my @adds    = map {
        my $dir = $_;
        die "Directory specified does not exist\n" unless ( -d $dir );

        my $rel_dir = $self->_rel2root($dir);
        die "Directory $dir already added\n" if ( grep { $rel_dir eq $_ } @watches );
        $rel_dir;
    } @_;

    open( my $watch, '>', $self->_rel2dir('.dest/watch') ) or die "Unable to write ~/.dest/watch file\n";
    print $watch $_, "\n" for ( sort @adds, map { $self->_rel2root($_) } @watches );
    mkpath("$self->{root_dir}/.dest/$_") for (@adds);

    return 0;
}

sub rm {
    my $self = _new(shift);
    die "No directory specified; usage: dest rm [directory]\n" unless @_;

    my @watches = $self->_watch_list;
    my @rms     = map {
        my $dir = $_;
        $dir //= '';
        $dir =~ s|/$||;

        die "Directory $dir not currently tracked\n" unless ( grep { $dir eq $_ } @watches );

        $self->_rel2root($dir);
    } @_;

    open( my $watch_file, '>', $self->_rel2dir('.dest/watch') ) or die "Unable to write ~/.dest/watch file\n";
    for my $watch_dir ( map { $self->_rel2root($_) } @watches ) {
        if ( grep { $watch_dir eq $_ } @rms ) {
            rmtree( $self->_rel2dir(".dest/$watch_dir") );
        }
        else {
            print $watch_file $watch_dir, "\n";
        }
    }

    return 0;
}

sub watches {
    my $self = _new(shift);

    my @watches = $self->_watch_list;
    print join( "\n", @watches ), "\n" if @watches;

    return 0;
}

sub putwatch {
    my $self   = _new(shift);
    my ($file) = @_;
    die "File specified does not exist\n" unless ( -f $file );

    open( my $new_watches, '<', $file ) or die "Unable to read specified file\n";

    my @new = map { chomp; $_ } <$new_watches>;
    my @old = $self->_watch_list;

    for my $old (@old) {
        next if ( grep { $_ eq $old } @new );
        $self->rm($old);
    }
    for my $new (@new) {
        next if ( grep { $_ eq $new } @old );
        $self->add($new);
    }

    return 0;
}

sub writewatch {
    my $self = _new(shift);

    copy( $self->_rel2dir('.dest/watch'), $self->_rel2dir('dest.watch') ) or die "$!\n";

    return 0;
}

sub make {
    my ( $self, $path, $ext ) = @_;
    die "No name specified; usage: dest make [path]\n" unless ($path);

    $path = strftime( $path, localtime );

    $ext = '.' . $ext if ( defined $ext );
    $ext //= '';

    try {
        mkpath($path);
        for ( qw( deploy verify revert ) ) {
            open( my $file, '>', "$path/$_$ext" ) or die;
            print $file "\n";
        }
    }
    catch ($e) {
        die "Failed to fully make $path; check permissions or existing files\n";
    }

    $self->expand($path);

    return 0;
}

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

    print join( ' ', map { <"$path/$_*"> } qw( deploy verify revert ) ), "\n";

    return 0;
}

sub list {
    my $self     = _new(shift);
    my ($filter) = @_;

    my $tree = $self->_actions_tree($filter);
    for my $path ( sort keys %$tree ) {
        print $path, ( ( @{ $tree->{$path} } ) ? ' actions:' : ' has no actions' ), "\n";
        print '  ', $_, "\n" for ( @{ $tree->{$path} } );
    }

    return 0;
}

sub prereqs {
    my $self = _new(shift);
    my ($filter) = @_;

    for my $action ( @{ $self->_prereq_tree($filter)->{actions} } ) {
        print $action->{action}, ( ( @{ $action->{prereqs} } ) ? ' prereqs:' : ' has no prereqs' ), "\n";
        print '  ', $_, "\n" for ( @{ $action->{prereqs} } );
    }

    return 0;
}

sub status {
    my $self = _new(shift);

    if ( -f $self->_rel2dir('dest.watch') ) {
        my $diff = Text::Diff::diff( $self->_rel2dir('.dest/watch'), $self->_rel2dir('dest.watch') );
        warn "Diff between current watch list and dest.watch file:\n" . $diff . "\n" if ($diff);
    }

    for my $path ( @{ $self->_status_data->{paths} } ) {
        print "$path->{state} - $path->{path}\n";

        for my $action ( @{ $path->{actions} } ) {
            unless ( $action->{modified} ) {
                print '  ' . ( ( $action->{deployed} ) ? '-' : '+' ) . ' ' . $action->{action} . "\n";
            }
            else {
                print "  $action->{action}\n";
                print "    M $action->{file}\n";
            }
        }
    }

    return 0;
}

sub diff {
    my $self   = _new(shift);
    my ($path) = @_;

    if ( not defined $path ) {
        $self->diff($_) for ( $self->_watch_list );
        return 0;
    }

    File::DirCompare->compare( $self->_rel2dir( '.dest/' . $self->_rel2root($path) ), $path, sub {
        my ( $a, $b ) = @_;
        $a ||= '';
        $b ||= '';

        return if ( $a =~ /\/dest.wrap$/ or $b =~ /\/dest.wrap$/ or not -f $a or not -f $b );
        print Text::Diff::diff( $a, $b );
        return;
    } );

    return 0;
}

sub clean {
    my $self = _new(shift);

    if (@_) {
        for (@_) {
            my $dest = $self->_rel2dir(".dest/$_");
            rmtree($dest);
            rcopy( $self->_rel2dir($_), $dest );
        }
    }
    else {
        for ( map { $self->_rel2root($_) } $self->_watch_list ) {
            my $dest = $self->_rel2dir(".dest/$_");
            rmtree($dest);
            dircopy( $self->_rel2dir($_), $dest );
        }
    }

    return 0;
}

sub preinstall {
    my $self = _new(shift);

    if (@_) {
        for (@_) {
            my $dest = $self->_rel2dir(".dest/$_");
            rmtree($dest);
        }
    }
    else {
        for ( map { $self->_rel2root($_) } $self->_watch_list ) {
            my $dest = $self->_rel2dir(".dest/$_");
            rmtree($dest);
            mkdir($dest);
        }
    }

    return 0;
}

sub nuke {
    my $self = _new(shift);
    rmtree( $self->_rel2dir('.dest') );
    return 0;
}

sub deploy {
    my $self = _new(shift);
    my ( $dry_run, $action ) = _dry_check(@_);
    die "File to deploy required; usage: dest deploy file\n" unless ($action);

    my $redeploy = delete $self->{redeploy};
    my $execute_stack = $self->_build_execute_stack( $action, 'deploy', undef, $redeploy );
    die "Action already deployed\n" if (
        not @$execute_stack or
        not scalar( grep { $_->{action} eq $action and $_->{type} eq 'deploy' } @$execute_stack )
    );

    unless ($dry_run) {
        $self->_execute_action($_) for (@$execute_stack);
    }
    else {
        _dry_run_report($execute_stack);
    }

    return 0;
}

sub redeploy {
    my $self = _new(shift);
    $self->{redeploy} = 1;
    return $self->deploy(@_);
}

sub revdeploy {
    my $self = _new(shift);
    my ($action) = @_;

    $self->revert($action);
    return $self->deploy($action);
}

sub verify {
    my $self = _new(shift);
    my ($action) = @_;

    return $self->_execute_action( $self->_build_execute_stack( $action, 'verify' )->[0] );
}

sub revert {
    my $self = _new(shift);
    my ( $dry_run, $action ) = _dry_check(@_);
    die "File to revert required; usage: dest revert file\n" unless ($action);

    my $execute_stack = $self->_build_execute_stack( $action, 'revert' );
    die "Action not deployed\n" if (
        not @$execute_stack or
        not scalar( grep { $_->{action} eq $action and $_->{type} eq 'revert' } @$execute_stack )
    );

    unless ($dry_run) {
        $self->_execute_action($_) for (@$execute_stack);
    }
    else {
        _dry_run_report($execute_stack);
    }

    return 0;
}

sub update {
    my $self = _new(shift);
    my ( $dry_run, @incs ) = _dry_check(@_);

    my $seen_action = {};
    my $execute_stack;

    for (
        sort {
            ( $b->{modified} || 0 ) <=> ( $a->{modified} || 0 ) ||
            $a->{action} cmp $b->{action}
        }
        grep { not $_->{matches} }
        values %{ $self->_status_data->{actions} }
    ) {
        push( @$execute_stack, @{ $self->_build_execute_stack( $_->{action}, 'revert' ) } ) if (
            $_->{modified} or $_->{deployed}
        );
        push( @$execute_stack, @{ $self->_build_execute_stack( $_->{action}, 'deploy', $seen_action ) } );
    }

    $execute_stack = [
        grep {
            my $execution = $_;
            my $match     = 0;

            for (@incs) {
                if ( index( $execution->{file}, $_ ) > -1 ) {
                    $match = 1;
                    last;
                }
            }

            $match;
        }
        @$execute_stack
    ] if (@incs);

    unless ($dry_run) {
        $self->_execute_action($_) for (@$execute_stack);
    }
    else {
        _dry_run_report($execute_stack);
    }

    return 0;
}

sub version {
    print 'dest version ', $__PACKAGE__::VERSION || 0, "\n";
    return 0;
}

sub _new {
    my ( $self, $expect_no_root_dir ) = @_;

    if ( not ref $self ) {
        $self = bless( {}, __PACKAGE__ );

        $self->{root_dir} = Path::Tiny->cwd;

        while ( not $self->{root_dir}->child('.dest')->is_dir ) {
            if ( $self->{root_dir}->is_rootdir ) {
                $self->{root_dir} = '';
                last;
            }
            $self->{root_dir} = $self->{root_dir}->parent;
            $self->{dir_depth}++;
        }

        if ( $expect_no_root_dir ) {
            die "Project already initialized\n" if $self->{root_dir};
        }
        else {
            die "Project not initialized\n" unless $self->{root_dir};
        }
    }

    return $self;
}

sub _dry_check {
    my @clean = grep { $_ ne '-d' } @_;
    return ( @clean != @_ ) ? 1 : 0, @clean;
}

sub _rel2root {
    my ( $self, $dir ) = @_;
    my $path           = path( $dir || '.' );

    try {
        $path = $path->realpath;
    }
    catch ($e) {
        $path = $path->absolute;
    }

    return $path->relative( $self->{root_dir} )->stringify;
}

sub _rel2dir {
    my ( $self, $dir ) = @_;
    return ( '../' x ( $self->{dir_depth} || 0 ) ) . ( $dir || '.' );
}

sub _watch_list {
    my ($self) = @_;
    open( my $watch, '<', $self->_rel2dir('.dest/watch') ) or die "Unable to read ~/.dest/watch file\n";
    return sort map { chomp; $self->_rel2dir($_) } <$watch>;
}

sub _actions_tree {
    my ( $self, $filter ) = @_;

    my $tree;
    for my $path ( $self->_watch_list ) {
        my @actions;

        find( {
            follow   => 1,
            no_chdir => 1,
            wanted   => sub {
                return unless ( m|/deploy(?:\.[^\/]+)?| );
                ( my $action = $_ ) =~ s|/deploy(?:\.[^\/]+)?||;

                push( @actions, $action ) if (
                    not defined $filter or
                    index( $action, $filter ) > -1
                );
            },
        }, $path );

        $tree->{$path} = [ sort @actions ];
    }

    return $tree;
}

sub _prereq_tree {
    my ( $self, $filter ) = @_;
    my $tree              = $self->_actions_tree($filter);

    my @actions;
    for my $path ( sort keys %$tree ) {
        for my $action ( @{ $tree->{$path} } ) {
            my ($file) = <"$action/deploy*">;
            open( my $content, '<', $file ) or die "Unable to read $file\n";

            my $prereqs = [
                map { $self->_rel2dir($_) }
                grep { defined }
                map { /dest\.prereq\b[\s:=-]+(.+?)\s*$/; $1 || undef }
                grep { /dest\.prereq/ } <$content>
            ];

            $action = {
                action  => $action,
                prereqs => $prereqs,
            };

            push( @actions, $action );
        }
    }

    return { tree => $tree, actions => \@actions };
}

sub _status_data {
    my ($self) = @_;

    my $actions;
    my $tree = $self->_actions_tree;
    for my $path ( keys %$tree ) {
        for my $action ( @{ $tree->{$path} } ) {
            $actions->{$action} = {
                action   => $action,
                deployed => 1,
                matches  => 1,
            };
        }
    }

    my @paths;
    for my $path ( $self->_watch_list ) {
        my $printed_path = 0;
        my $data;

        try {
            File::DirCompare->compare(
                $self->_rel2dir( '.dest/' . $self->_rel2root($path) ),
                $path,
                sub {
                    my ( $a, $b ) = @_;
                    return if ( $a and $a =~ /\/dest.wrap$/ or $b and $b =~ /\/dest.wrap$/ );
                    $data->{state} = 'diff' unless ( $printed_path++ );

                    if ( not $b ) {
                        push(
                            @{ $data->{actions} },
                            {
                                action   => $self->_rel2dir( substr( $self->_rel2root($a), 6 ) ),
                                deployed => 1,
                            },
                        );
                    }
                    elsif ( not $a ) {
                        push(
                            @{ $data->{actions} },
                            {
                                action   => $b,
                                deployed => 0,
                            },
                        );
                    }
                    elsif ( $a and $b ) {
                        ( my $action = $b ) =~ s,/(?:deploy|verify|revert)(?:\.[^\/]+)?$,,;
                        push(
                            @{ $data->{actions} },
                            {
                                action   => $action,
                                modified => 1,
                                file     => $b,
                            },
                        );
                    }

                    return;
                },
            )
        }
        catch ($e) {
            $data->{state} = '?' if ( $e =~ /Not a directory/ );
        }
        finally {
            $data->{state} = 'ok' unless $printed_path;
        }

        $data->{path} = $path;
        push( @paths, $data );

        if ( ref $data->{actions} eq 'ARRAY' ) {
            $actions->{ $_->{action} } = $_ for ( @{ $data->{actions} } );
        }
    }

    return { paths => \@paths, actions => $actions };
}

sub _build_execute_stack {
    my ( $self, $name, $type, $seen_action, $redeploy ) = @_;

    my @actions_stack = ($name);
    my $prereqs       = { map { $_->{action} => $_->{prereqs} } @{ $self->_prereq_tree->{actions} } };
    my $state         = $self->_status_data->{actions};

    if ( $type eq 'revert' ) {
        my $postreqs;
        for my $action ( keys %$prereqs ) {
            push( @{ $postreqs->{$_} }, $action ) for ( @{ $prereqs->{$action} } );
        }
        $prereqs = $postreqs;
    }

    my ( @execute_stack, $wraps );
    $seen_action //= {};

    while (@actions_stack) {
        my $action = shift @actions_stack;
        next if ( $seen_action->{$action}++ );
        push( @actions_stack, @{ $prereqs->{$action} || [] } );

        my $location = ( $type ne 'revert' )
            ? $action
            : $self->_rel2dir( '.dest/' . $self->_rel2root($action) );

        my $file = ( <"$location/$type*"> )[0];

        unless ( exists $wraps->{$action} ) {
            $wraps->{$action} = undef;
            my @nodes = split( '/', $self->_rel2root($file) );
            pop @nodes;
            shift @nodes if ( defined $nodes[0] and $nodes[0] eq '.dest' );
            while (@nodes) {
                my $path = $self->_rel2dir( join( '/', @nodes ) . '/dest.wrap' );
                if ( -f $path ) {
                    $wraps->{$action} = $path;
                    last;
                }
                pop @nodes;
            }
        }

        my $add = sub {
            die "Action file does not exist for: $type $action\n" unless ($file);

            my $executable = ( $wraps->{$action} ) ? $wraps->{$action} : $file;
            die 'Execute permission denied for: ' . $executable . "\n" unless ( -x $executable );

            unshift(
                @execute_stack,
                {
                    type   => $type,
                    action => $action,
                    file   => $file,
                    wrap   => $wraps->{$action},
                },
            );

            if ( $type eq 'deploy' ) {
                my $verify_file = ( <"$action/verify*"> )[0];
                die "Action file does not exist for: verify $action\n" unless ($verify_file);

                splice(
                    @execute_stack,
                    1,
                    0,
                    {
                        type   => 'verify',
                        action => $action,
                        file   => $verify_file,
                        wrap   => $wraps->{$action},
                    },
                );
            }
        };

        if ( $type eq 'deploy' ) {
            $add->() unless ( $state->{$action}{deployed} and not $redeploy );
        }
        elsif ( $type eq 'revert' ) {
            $add->() if ( $state->{$action}{deployed} or $state->{$action}{modified} );
        }
        elsif ( $type eq 'verify' ) {
            $add->();
        }
    }

    return \@execute_stack;
}

sub _dry_run_report {
    my ($execute_stack) = @_;
    print '' . ( ( $_->{wrap} ) ? $_->{wrap} . ' ' : '' ) . $_->{file}, "\n" for (@$execute_stack);
}

sub _execute_action {
    my ( $self, $input ) = @_;
    my ( $type, $wrap, $action, $file, $location ) = @$input{ qw( type wrap action file location ) };

    my ( $out, $err, $died );
    my $run = sub {
        try {
            run(
                [ ( grep { defined } $wrap ), $file, $type ],
                \undef, \$out, \$err,
            ) or $died = 1;
        }
        catch ($e) {
            $err = $e;
        }

        if ($err) {
            ( my $err_str = $err ) =~ s/\s*at\s+.*$//;
            chomp($err_str);
            if ($died) {
                die "Failed to execute $file: $err_str\n";
            }
            else {
                warn "Warnings from executed $file: $err_str\n";
            }
        }
    };

    if ( $type eq 'verify' ) {
        $run->();
        chomp($out);
        die "$err\n" if ($err);

        if ($out) {
            print "ok - verify: $action\n";
        }
        else {
            die "not ok - verify: $action\n";
        }
    }
    else {
        print "begin - $type: $action\n";
        $run->();
        print "ok - $type: $action\n";
    }

    my $dest_copy = $self->_rel2dir( '.dest/' . $self->_rel2root($action) );
    rmtree($dest_copy) unless ( $type eq 'verify' );
    dircopy( $action, $dest_copy ) if ( $type eq 'deploy' );

    return 0;
}

1;

__END__