view release on metacpan or  search on metacpan

lib/App/karr/Git.pm  view on Meta::CPAN

    my $left = $deadline - Time::HiRes::time();
    if ( $ENV{KARR_NO_CLI_FALLBACK} ) {
        # Native only: whatever it said is the whole answer.
    }
    elsif ( $left <= 0 ) {
        $why = "no answer within ${budget}s";
    }
    else {
        my $run = $self->_run_git( { timeout => $left },
            'ls-remote', '--quiet', $remote, BOARD_ROOT . '*' );

        if ( $run->{ok} && !$run->{status} ) {
            # An answer with no ref in it is an answer: the remote has no board.
            return $run->{out} =~ /\S/ ? 1 : 0;
        }

        # git's first line is the one that says what went wrong ("ssh: connect
        # to host ...", "fatal: '/x' does not appear to be a git repository");
        # the rest is the standard advice underneath it, and this becomes one
        # line in front of a refusal that has four of its own.
        my $detail = $run->{err} // '';
        $detail =~ s/\s+\z//;
        $detail = ( split /\n/, $detail )[0] // '';
        # No git to run leaves the native attempt as the only thing that
        # happened, so its reason is carried along. The timeout names the whole
        # probe's deadline rather than the slice this attempt was given: what
        # the caller waited through is both attempts together.
        my $start = "could not run git: $detail"
            . ( defined $native_why ? " (native: $native_why)" : '' );
        $why =
              $run->{failure} eq 'start'   ? $start
            : $run->{failure} eq 'timeout' ? "no answer within ${budget}s"
            : length $detail               ? $detail
            :                                "git ls-remote exited " . ( $run->{status} >> 8 );
    }

    $self->{_last_error} = $why // 'the remote could not be asked';
    return undef;
}


# Default credentials callback: SSH-agent → ~/.ssh/id_ed25519 → ~/.ssh/id_rsa
# → default → fail. Matches CLI `git`'s implicit auth chain.
sub _default_credentials_cb {
    my @tried;
    return sub {
        my (%args) = @_;
        my $user  = $args{username_from_url} || 'git';
        my $types = $args{allowed_types}    || 0;

        # GIT_CREDENTIAL_SSH_KEY = 1<<1 = 2
        if ( $types & 2 ) {
            return Git::Native::Credential->ssh_agent( username => $user )
                unless $tried[0]++;
            for my $k (qw( id_ed25519 id_rsa )) {
                my $priv = "$ENV{HOME}/.ssh/$k";
                next unless -r $priv;
                next if $tried[1]{$k}++;
                return Git::Native::Credential->ssh_key(
                    username    => $user,
                    private_key => $priv,
                    public_key  => "$priv.pub",
                    passphrase  => '',
                );
            }
        }
        # GIT_CREDENTIAL_DEFAULT = 1<<3 = 8
        if ( ( $types & 8 ) && !$tried[2]++ ) {
            return Git::Native::Credential->default;
        }
        return undef;   # PASSTHROUGH — give up
    };
}

sub fetch {
    my ( $self, $remote ) = @_;
    $remote //= 'origin';
    my $repo = $self->_repo or return 0;
    return 1 unless $repo->has_remote($remote);
    # The Result's ->updated names the refs a fetch actually moved. karr
    # deliberately does not use it: reconciliation has to consider the refs the
    # fetch did *not* move as well (unpushed local work is exactly that), so it
    # reads the ref OIDs itself -- and the CLI transport has no such list to
    # hand back, so consuming it would make the two transports differ again,
    # which is what #41 was. ->rejected is always empty on fetch.
    return $self->_fetch_refspecs( $remote, [] );   # configured refspecs
}


# Per-ref rejections from the most recent push, as
# [ { ref => $name, reason => $text }, ... ]. Empty when the last push
# succeeded, and empty when it failed as a whole (no connection, killed
# transport) rather than ref by ref -- a rejection is the server's final
# answer, so App::karr::Role::SyncLifecycle uses this to stop retrying it.
sub push_rejections {
    my ($self) = @_;
    return $self->{_push_rejections} || [];
}


# Reasons the receiving side gives for "another push got to this ref first",
# as opposed to "I refuse this ref". The wording is all karr gets, so both
# transports' phrasings are named here:
#
#   a reference with that name already exists
#       libgit2's local transport -- a bare repo reached by a path or by
#       file://, which is what the tests and the reproducers use. It looks the
#       destination ref up, finds nothing, and creates it *without* force, so
#       a ref another push created in between fails the create. karr never
#       asks for a forceless create: the board refspec is +refs/karr/*.
#
#   failed to update ref
#       git-receive-pack, which is what every real ssh/https/git:// remote
#       runs, reported over either transport (libgit2's smart protocol, or
#       `git push --porcelain`). It is receive-pack's status for a ref
#       transaction that would not commit: the old value the pusher was
#       advertised no longer matches, or the ref it wanted to create now
#       exists. The detail goes to the sideband as "cannot lock ref 'X':
#       reference already exists" and never into the status line, so this
#       bare wording is what arrives.
#