#!/usr/bin/env perl

package Git::Hooks::CheckRewrite;
# ABSTRACT: Git::Hooks plugin for checking against unsafe rewrites
$Git::Hooks::CheckRewrite::VERSION = '2.1.5';
use 5.010;
use utf8;
use strict;
use warnings;
use Try::Tiny;
use Path::Tiny;
use Git::Hooks;

my $PKG = __PACKAGE__;
(my $CFG = __PACKAGE__) =~ s/.*::/githooks./;

##########

# Returns a Path::Tiny object represeting the name of a file where we record
# information about a commit that has to be shared between the pre- and
# post-commit hooks.
sub _record_filename {
    my ($git) = @_;

    return path($git->git_dir())->child('GITHOOKS_CHECKREWRITE');
}

# Returns all branches containing a specific commit. The command "git
# branch" returns the branch names prefixed with two characters, which
# we have to get rid of using substr.
sub _branches_containing {
    my ($git, $commit) = @_;
    return map { substr($_, 2) } $git->run('branch', '-a', '--contains', $commit);
}

sub record_commit_parents {
    my ($git) = @_;

    # Here we record the HEAD commit's own id and it's parent's ids in
    # a file under the git directory. The file has two lines in this
    # format:

    # commit SHA1
    # SHA1 SHA1 ...

    # The first line holds the HEAD commit's id and the second the ids of
    # its parents. In a brand new repository the rev-list command applied to
    # HEAD dies in error because HEAD isn't defined yet. This is why we
    # evaluate the command and replace its value by the empty string below.

    my $commit_parents = eval { $git->run(qw/rev-list --pretty=format:%P -n 1 HEAD/) } || '';

    _record_filename($git)->spew($commit_parents);

    return 1;
}

sub check_commit_amend {
    my ($git) = @_;

    my $record_file = _record_filename($git);

    -r $record_file
        or $git->error($PKG, "cannot read $record_file. You probably forgot to symlink the pre-commit hook")
            and return 0;

    my ($old_commit, $old_parents) = $record_file->lines;

    # For a brand new repository the commit information is empty and we
    # don't have to check anything.
    return 1 unless $old_commit;

    chomp $old_commit;
    $old_commit =~ s/^commit\s+//;

    if (defined $old_parents) {
        chomp $old_parents;
    } else {
        # the repo's first commit has no parents.
        $old_parents = '';
    }

    my $new_parents = ($git->run(qw/rev-list --pretty=format:%P -n 1 HEAD/))[1];

    return 1 if $new_parents ne $old_parents;

    # Find all branches containing $old_commit
    my @branches = _branches_containing($git, $old_commit);

    if (@branches > 0) {
        # $old_commit is reachable by at least one branch, which means
        # the amend was unsafe.
        my $branches = join "\n    ", @branches;
        $git->error($PKG, "unsafe commit", <<"EOF");
You've just performed un unsafe "git commit --amend" because your
original HEAD ($old_commit) is still reachable by the following
branch(es):

    $branches

Consider amending it again:

    git commit --amend      # to amend it
EOF
        return 0;
    }

    return 1;
}

sub check_rebase {
    my ($git, $upstream, $branch) = @_;

    unless (defined $branch) {
        # This means we're rebasing the current branch. We try to grok
        # it's name using git symbolic-ref.
        my $success = try {
            chomp($branch = $git->run(qw/symbolic-ref -q HEAD/));
        } catch {
            # The command git symbolic-ref fails if we're in a
            # detached HEAD. In this situation we don't care about the
            # rewriting.
            undef;
        };
        return 1 unless defined $success;
    }

    # Find the base commit of the rebased sequence
    my $base_commit = $git->run(qw/rev-list --topo-order --reverse/, "$upstream..$branch");

    # If $upstream is a decendant of $branch, $base_commit is
    # empty. In this situation the rebase will turn out to be a simple
    # fast-forward merge from $branch on $upstream and there is
    # nothing to lose.
    return 1 unless $base_commit;

    # Find all branches containing that commit
    my @branches = _branches_containing($git, $base_commit);

    if (@branches > 1) {
        # The base commit is reachable by more than one branch, which
        # means the rewrite is unsafe.
        my $branches = join("\n    ", grep {$_ ne $branch} @branches);
        $git->error($PKG, "unsafe rebase", <<"EOF");
This is an unsafe rebase because it would rewrite commits shared by
$branch and the following other branch(es):

    $branches
EOF
        return 0;
    }

    return 1;
}

# Install hooks
PRE_COMMIT  \&record_commit_parents;
POST_COMMIT \&check_commit_amend;
PRE_REBASE  \&check_rebase;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Git::Hooks::CheckRewrite - Git::Hooks plugin for checking against unsafe rewrites

=head1 VERSION

version 2.1.5

=head1 DESCRIPTION

This L<Git::Hooks> plugin hooks itself to the B<pre-rebase> hook to
guarantee that it is safe in the sense that no rewritten commit is reachable
by other branch than the one being rebased.

It also hooks itself to the B<pre-commit> and the B<post-commit> hooks
to detect unsafe B<git commit --amend> commands after the fact. An
amend is unsafe if the original commit is still reachable by any
branch after being amended. Unfortunately B<git> still does not
provide a way to detect unsafe amends before committing them.

To enable it you should add it to the githooks.plugin configuration
option:

    git config --add githooks.plugin CheckRewrite

=for Pod::Coverage check_commit_amend check_rebase record_commit_parents

=head1 NAME

Git::Hooks::CheckRewrite - Git::Hooks plugin for checking against unsafe rewrites

=head1 CONFIGURATION

There's no configuration needed or provided.

=head1 REFERENCES

Here are some references about what it means for a rewrite to be
unsafe and how to go about detecting them in git:

=over

=item * L<http://git.661346.n2.nabble.com/pre-rebase-safety-hook-td1614613.html>

=item * L<http://git.apache.org/xmlbeans.git/hooks/pre-rebase.sample>

=item * L<http://www.mentby.com/Group/git/rfc-pre-rebase-refuse-to-rewrite-commits-that-are-reachable-from-upstream.html>

=item * L<http://git.661346.n2.nabble.com/RFD-Rewriting-safety-warn-before-when-rewriting-published-history-td7254708.html>

=back

=head1 AUTHOR

Gustavo L. de M. Chaves <gnustavo@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by CPqD <www.cpqd.com.br>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut