path: root/lib/perl5/Local/MrRepo/Repo/Git/Annex.pm

package Local::MrRepo::Repo::Git::Annex;

# Copyright (C) 2019-2020 Sean Whitton
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use 5.018;
use strict;
use warnings;
use lib "$ENV{HOME}/lib/perl5";
use parent 'Local::MrRepo::Repo::Git';

use Data::Compare;
use Exporter 'import';
use File::Spec::Functions qw(rel2abs catfile);
use Git::Wrapper;
use JSON;
use Local::ScriptStatus;
use Try::Tiny;
use Term::ReadKey;
use Local::Interactive qw(prompt prompt_yn);
use Storable;
use List::Util qw(all);

our @EXPORT_OK = ();

sub review {
    my $self = shift;

    my $issues = $self->SUPER::review(@_);

    # if there were git issues, fail now, as the annex issues can
    # produce copious output and it is nice to know there were no git
    # issues when reviewing the annex issues
    return $issues if $issues;

    # another command we could consider running is `git annex fsck --fast`

    # 1. Check for files stored only locally where that's not okay
    my @annex_find_output = $self->git->annex("find", "--json",
  "--in", "here", "--and", "--not", "--copies=2", "--and", "--lackingcopies=1");
    unless (@annex_find_output == 0) {
        say_spaced_bullet("Some annex content is present only locally:");
        say "  $_" for map { ${decode_json($_)}{file} } @annex_find_output;
        print "\n";
        say_bold
          ("  use `git annex sync --content' to fix this (`mr push' should be");
        say_bold
          ("  configured to run that command with the right remotes)");
        $issues = 1;
    }
    # 2. Check for unused files which we should be able to clean up
    my ($review_unused) = $self->git->config(qw(--local --get --type=bool
                                                --default true
                                                mrrepo.review-unused));
    $issues = $self->review_unused(interactive => 0) || $issues
      if $review_unused eq 'true';

    return $issues;
}

sub review_unused {
    my $self = shift;
    my %opts = @_;

    my $used_refspec_config;
    try { ($used_refspec_config) = $self->git->config("annex.used-refspec") };

    $opts{interactive} //= 0;
    # only supply a default value for this if annex.used-refspec has
    # not been configured, so that annex.used-refspec takes effect if
    # our caller does not supply a used_refspec
    $opts{used_refspec} //= "+refs/heads/*:-refs/heads/synced/*"
      unless defined $used_refspec_config;

    my %unused_args = ();
    $unused_args{used_refspec} = $opts{used_refspec}
      if exists $opts{used_refspec};
    my %dropunused_args = (force => 1);
    $unused_args{from} = $dropunused_args{from} = $opts{from}
      if defined $opts{from};

    my @to_drop      = ();
    my $unused_files = $self->unused_files(\%unused_args);
    $self->log_unused();
    my @unused_files = @$unused_files;
    return 0 if @unused_files == 0;
    unless ($opts{interactive}) {
        say_spaced_bullet("There are unused files you can drop with"
              . " `git annex dropunused':");
        say "    " . $_->{number} . "     " . $_->{key} for @unused_files;
        print "\n";
    }

    my ($uuid) = $self->git->config("remote." . $opts{from} . ".annex-uuid")
      if defined $opts{from};

    my $i = 0;
  UNUSED: while ($i < @unused_files) {
        my $unused_file = $unused_files[$i];

        # check the unused file still exists i.e. has not been dropped
        # already (in the case of reviewing unused files at a remote,
        # just check that it's not been dropped according to the local
        # git-annex branch) use checkpresentkey in that case
        my $contentlocation = $self->abs_contentlocation($unused_file->{key});
        if (defined $opts{from}) {
            try {
                $self->git->annex("readpresentkey", $unused_file->{key},
                    $uuid);
            }
            catch {
                splice @unused_files, $i, 1;
                next UNUSED;
            };
        } elsif (!defined $contentlocation) {
            splice @unused_files, $i, 1;
            next UNUSED;
        }

        system('clear', '-x') if $opts{interactive};
        say_bold("unused file #" . $unused_file->{number} . ":");

        if ($unused_file->{bad} || $unused_file->{tmp}) {
            say "  looks like stale tmp or bad file, with key "
              . $unused_file->{key};
        } else {
            my @log_lines = @{ $unused_file->{log_lines} };
            if ($opts{interactive}) {
                # truncate log output if necessary to ensure user's
                # terminal does not scroll
                my (undef, $height, undef, undef) = GetTerminalSize();
                splice @log_lines, (($height - 5) - @log_lines)
                  if @log_lines > ($height - 5);
            }
            print "\n";
            say for @log_lines;
            if ($opts{interactive}) {
                my $response;
                while (1) {
                    # before prompting, clear out stdin, to avoid
                    # registered a keypress more than once
                    ReadMode 4;
                    while (defined ReadKey(-1)) { }

                    my @opts = ('y', 'n');
                    push @opts, 'o' if defined $contentlocation;
                    push @opts, ('d', 'b') if $i > 0;
                    print "Drop this unused files?  ("
                      . join('/', @opts) . ") ";

                    # Term::ReadKey docs recommend ReadKey(-1) but
                    # that means we need an infinite loop calling
                    # ReadKey(-1) over and over, which ramps up system
                    # load
                    my $response = ReadKey(0);
                    ReadMode 0;

                    # respond to C-c
                    exit 0 if ord($response) == 3;

                    say $response;
                    $response = lc($response);
                    if ($response eq 'y') {
                        push @to_drop, $unused_file->{number};
                        last;
                    } elsif ($response eq 'n') {
                        last;
                    } elsif ($response eq 'o' and defined $contentlocation) {
                        system('xdg-open', $contentlocation);
                    } elsif ($response eq 'b' and $i > 0) {
                        $i--;
                        pop @to_drop
                          if @to_drop
                          and $to_drop[$#to_drop] eq
                          $unused_files[$i]->{number};
                        next UNUSED;
                    } elsif ($response eq 'd' and $i > 0) {
                        # user wants to drop the list we've
                        # accumulated up until now and get out of this
                        # script
                        last UNUSED;
                    } else {
                        say "invalid response";
                    }
                }
            }
        }
        print "\n";
        $i++;
    }

    if (@to_drop) {
        say_spaced_bullet("Will dropunused"
              . (exists $dropunused_args{force} ? " with --force:" : ":"));
        say "@to_drop\n";
        $self->git->annex("dropunused", \%dropunused_args, @to_drop)
          if prompt_yn("Go ahead with this?");
    }
    # return boolean value representing whether or not there are any
    # unused files left after this run.  note in non-interactive mode
    # @to_drop will be empty so will always return 1 if we got this
    # far in the subroutine
    if (@to_drop == @unused_files) {
        delete $self->{_unused_files};
        unlink $self->_unused_cache_file;
        return 0;
    } else {
        return 1;
    }
}


sub unused_files {
    my ($self, $unused_args) = @_;

    my $cache_file = $self->_unused_cache_file;
    $self->{_unused_files} //= retrieve($cache_file) if -e $cache_file;

    # see if cached result needs to be invalidated
    if (defined $self->{_unused_files}) {
        my $annex_dir = $self->git_path("annex");
        my $last_unused = (stat(catfile($annex_dir, "unused")))[9];
        my %branch_timestamps
          = map { split ' ' }
          $self->git->for_each_ref(
            { format => '%(refname:short) %(committerdate:unix)' },
            "refs/heads/");

        # we don't need to invalidate the cache if the git-annex
        # branch has changed, because the worst that can happen is we
        # try to drop a file which has already been dropped
        delete $branch_timestamps{'git-annex'};

        if (    $last_unused <= $self->{_unused_files}->{timestamp}
            and Compare($unused_args, $self->{_unused_files}->{unused_args})
            and all { $_ < $last_unused } values %branch_timestamps) {
            return $self->{_unused_files}->{unused};
        } else {
            delete $self->{_unused_files};
        }
    }

    # if we're still in the method at this point then the cache was
    # invalidated; regenerate it
    my ($bad, $tmp) = (0, 0);
    %{ $self->{_unused_files}->{unused_args} } = %$unused_args;
    foreach ($self->git->annex("unused", $unused_args)) {
        if (/Some corrupted files have been preserved by fsck, just in case/) {
            ($bad, $tmp) = (1, 0);
        } elsif (/Some partially transferred data exists in temporary files/) {
            ($bad, $tmp) = (0, 1);
        } elsif (/^    ([0-9]+) +([^ ]+)$/) {
            push @{ $self->{_unused_files}->{unused} },
              { number => $1, key => $2, bad => $bad, tmp => $tmp };
        }
    }
    $self->{_unused_files}->{timestamp} = time();
    $self->_store_unused();
    return $self->{_unused_files}->{unused};
}

sub log_unused {
    my $self = shift;

    foreach my $unused_file (@{ $self->{_unused_files}->{unused} }) {
        next if defined $unused_file->{log_lines};
        # We need the RUN here to avoid special postprocessing but
        # also to get the -c option passed -- unclear how to pass
        # short options to git itself, not the 'log' subcommand,
        # with Git::Wrapper except by using RUN (passing long
        # options to git itself is easy, per Git::Wrapper docs)
        @{ $unused_file->{log_lines} } = map { s/^/  /r } $self->git->RUN(
            "-c",
            "diff.renameLimit=3000",
            "log",
            {
                stat        => 1,
                no_textconv => 1
            },
            "--color=always",
            "-S",
            $unused_file->{key});
    }
    $self->_store_unused();
}

sub _store_unused {
    my $self = shift;
    store($self->{_unused_files}, $self->_unused_cache_file);
}

sub _unused_cache_file {
    my $annex_dir = shift->git_path("annex");
    return catfile($annex_dir, "unused_info");
}

sub abs_contentlocation {
    my $self = shift;
    my $key  = shift;

    my $contentlocation;
    try {
        ($contentlocation) = $self->git->annex("contentlocation", $key);
    }
    catch {
        undef $contentlocation;
    };
    return (defined $contentlocation)
      ? rel2abs($contentlocation, $self->toplevel)
      : undef;
}

1;