view release on metacpan or  search on metacpan

lib/Git/Native/Remote.pm  view on Meta::CPAN

  return Git::Native::Remote::Result->new(
    updated  => \@updated,
    rejected => \@rejected,
  );
}

# List the remote-side refs (requires connecting first). Returns an
# arrayref of names. Caller passes credentials cb so private remotes work.
sub list_refs {
  my ( $self, %args ) = @_;
  $self->_connect( GIT_DIRECTION_FETCH, $args{credentials} );
  my @names;
  eval {
    check_rc Git::Libgit2::FFI::git_remote_ls(
      \my $heads_arr, \my $count, $self->_handle,
    );
    # heads_arr is git_remote_head**: an array of $count pointers,
    # each pointing to a git_remote_head whose .name (char*) lives at
    # offset REMOTE_HEAD_NAME_OFFSET.
    my $ffi = Git::Libgit2::FFI::ffi();
    for ( my $i = 0; $i < $count; $i++ ) {
      my $head_ptr = unpack 'J',
        _peek_bytes( $heads_arr + $i * PTR_SIZE, PTR_SIZE );
      my $name_ptr = unpack 'J',
        _peek_bytes( $head_ptr + REMOTE_HEAD_NAME_OFFSET, PTR_SIZE );
      my $name = $ffi->cast( 'opaque' => 'string', $name_ptr );
      CORE::push @names, $name;
    }
  };
  my $err = $@;
  Git::Libgit2::FFI::git_remote_disconnect( $self->_handle );
  die $err if $err;
  return \@names;
}

sub _connect {
  my ( $self, $direction, $cred_cb ) = @_;
  # Build a callbacks struct on the stack-ish (Perl-owned buffer).
  my $cb = "\0" x CALLBACKS_SIZE;
  my ($cb_ptr) = scalar_to_buffer($cb);
  check_rc Git::Libgit2::FFI::git_remote_init_callbacks(
    $cb_ptr, GIT_REMOTE_CALLBACKS_VERSION,
  );
  my @keep = ( \$cb );
  if ($cred_cb) {
    my ( $thunk, $thunk_keep ) = _make_credential_thunk($cred_cb);
    CORE::push @keep, $thunk_keep;
    my $ptr_val = Git::Libgit2::FFI::ffi->cast(
      'git_credential_acquire_cb' => 'opaque', $thunk,
    );
    my $pkt = pack 'J', $ptr_val;
    my ($pkt_p) = scalar_to_buffer($pkt);
    memcpy( $cb_ptr + CALLBACKS_CRED_OFFSET, $pkt_p, 8 );
    CORE::push @keep, \$pkt;
  }
  _install_certcheck( $cb_ptr, 0, \@keep );
  check_rc Git::Libgit2::FFI::git_remote_connect(
    $self->_handle, $direction, $cb_ptr, 0, 0,
  );
  # Hold keepalive on $self so it survives until the next call frees it.
  $self->{_connect_keep} = \@keep;
  return $self;
}

# Compute delete refspecs for `--prune`: for each `[+]src:dst` with `*`,
# list remote refs matching the dst pattern, and emit a delete for each
# one whose local counterpart no longer exists.
sub _compute_prune_deletes {
  my ( $self, $refspecs, $cred_cb ) = @_;
  my $remote_names = $self->list_refs( credentials => $cred_cb );
  my %local;
  $local{$_} = 1 for @{ $self->_owner->reference_names };

  my @deletes;
  my %seen;
  # Walk *original* user refspecs to figure out the dst-pattern namespace.
  # We can't recover the dst-pattern from already-expanded specs.
  for my $rs (@$refspecs) {
    my ( $force, $src, $dst ) = $rs =~ /\A(\+?)([^:]+):(.+)\z/;
    next unless defined $src && $dst =~ /\*/;
    # Map remote ref → expected local name using dst→src.
    my $dst_re = quotemeta($dst); $dst_re =~ s/\\\*/(.*)/;
    $dst_re = qr/\A${dst_re}\z/;
    my $src_template = $src;
    for my $rname (@$remote_names) {
      my ($cap) = $rname =~ $dst_re;
      next unless defined $cap;
      my $expected_local = $src_template;
      $expected_local =~ s/\*/$cap/;
      next if $local{$expected_local};
      next if $seen{$rname}++;
      CORE::push @deletes, ":${rname}";
    }
  }
  return @deletes;
}

# Read N bytes from a raw C address into a Perl scalar.
sub _peek_bytes {
  my ( $addr, $len ) = @_;
  my $buf = "\0" x $len;
  my ($bp) = scalar_to_buffer($buf);
  memcpy( $bp, $addr, $len );
  return $buf;
}

# libgit2 git_remote_push does NOT expand wildcard refspecs (unlike CLI
# git). We do it here: for each `+?src:dst` refspec containing `*`,
# enumerate matching local refs and emit one explicit refspec per ref.
sub _expand_push_refspecs {
  my ( $self, $refspecs ) = @_;
  $refspecs //= [];
  my @out;
  for my $rs (@$refspecs) {
    my ( $force, $src, $dst ) = $rs =~ /\A(\+?)([^:]+):(.+)\z/;
    if ( !defined $src || ( index( $src, '*' ) < 0 && index( $dst, '*' ) < 0 ) ) {
      CORE::push @out, $rs;
      next;
    }
    my $src_re = quotemeta($src);
    $src_re =~ s/\\\*/(.*)/;
    $src_re = qr/\A${src_re}\z/;

    my $names = $self->_owner->reference_names( glob => $src );
    for my $name (@$names) {
      my ($cap) = $name =~ $src_re;
      next unless defined $cap;
      my $expanded_dst = $dst;
      $expanded_dst =~ s/\*/$cap/;
      CORE::push @out, "${force}${name}:${expanded_dst}";
    }
  }
  return \@out;
}

# ---------- internals ----------

# Build a git_strarray pointing into Perl-owned memory. Returns
# ($strarray_ptr, $keepalive_scalars_ref). Caller must hold
# $keepalive_scalars_ref alive across the C call.
sub _build_strarray {
  my ($refspecs) = @_;
  $refspecs //= [];
  Carp::croak "_build_strarray: refspecs must be an arrayref"
    if ref $refspecs ne 'ARRAY';
  # Empty list → NULL strarray pointer, which libgit2 reads as
  # "use configured refspecs from .git/config".
  return ( 0, [] ) unless @$refspecs;

  # Copy each string so we have stable storage we control.
  my @copies = map { "$_" } @$refspecs;
  my @ptrs;
  for my $s (@copies) {
    my ($p) = scalar_to_buffer($s);
    CORE::push @ptrs, $p;
  }
  my $strings_buf = pack 'J*', @ptrs;
  my ($strings_ptr) = scalar_to_buffer($strings_buf);

  my $strarray = pack 'JJ', $strings_ptr, scalar(@copies);
  my ($sa_ptr) = scalar_to_buffer($strarray);

  # Keep refs to every buffer that owns memory referenced from $strarray.
  return ( $sa_ptr, [ \@copies, \$strings_buf, \$strarray ] );
}

sub _build_fetch_options {
  my ( $cred_cb, $prune, $update_tips_thunk ) = @_;

  my $opts = "\0" x FETCH_OPTIONS_SIZE;
  my ($opts_ptr) = scalar_to_buffer($opts);
  check_rc Git::Libgit2::FFI::git_fetch_options_init(
    $opts_ptr, GIT_FETCH_OPTIONS_VERSION,
  );

  my @keep = ( \$opts );

  if ($cred_cb) {
    my ( $cb_thunk, $cb_keep ) = _make_credential_thunk($cred_cb);
    CORE::push @keep, $cb_keep;

    # Write the closure's C pointer into callbacks.credentials.
    my $cb_ptr_val = Git::Libgit2::FFI::ffi->cast(
      'git_credential_acquire_cb' => 'opaque', $cb_thunk,
    );
    my $cb_buf = pack 'J', $cb_ptr_val;
    my ($cb_buf_ptr) = scalar_to_buffer($cb_buf);
    memcpy( $opts_ptr + FETCH_OPTS_CALLBACKS_OFFSET + CALLBACKS_CRED_OFFSET,
            $cb_buf_ptr, 8 );
    CORE::push @keep, \$cb_buf;
  }

  _install_certcheck( $opts_ptr, FETCH_OPTS_CALLBACKS_OFFSET, \@keep );

  if ($update_tips_thunk) {
    my $ptr_val = Git::Libgit2::FFI::ffi->cast(
      'git_remote_update_tips_cb' => 'opaque', $update_tips_thunk,
    );
    my $buf = pack 'J', $ptr_val;
    my ($bp) = scalar_to_buffer($buf);
    memcpy( $opts_ptr + FETCH_OPTS_CALLBACKS_OFFSET
            + CALLBACKS_UPDATE_TIPS_OFFSET, $bp, 8 );
    CORE::push @keep, \$buf;
  }

  if ( defined $prune ) {
    my $val = $prune ? 1 : 2;   # 1 = PRUNE, 2 = NO_PRUNE
    my $pb  = pack 'l', $val;
    my ($pbp) = scalar_to_buffer($pb);
    memcpy( $opts_ptr + FETCH_OPTS_PRUNE_OFFSET, $pbp, 4 );
    CORE::push @keep, \$pb;
  }

  return ( $opts_ptr, \@keep );
}

sub _build_push_options {
  my ( $cred_cb, $push_update_thunk ) = @_;

  my $opts = "\0" x PUSH_OPTIONS_SIZE;
  my ($opts_ptr) = scalar_to_buffer($opts);
  check_rc Git::Libgit2::FFI::git_push_options_init(
    $opts_ptr, GIT_PUSH_OPTIONS_VERSION,
  );

  my @keep = ( \$opts );

  if ($cred_cb) {
    my ( $cb_thunk, $cb_keep ) = _make_credential_thunk($cred_cb);
    CORE::push @keep, $cb_keep;

    my $cb_ptr_val = Git::Libgit2::FFI::ffi->cast(
      'git_credential_acquire_cb' => 'opaque', $cb_thunk,
    );
    my $cb_buf = pack 'J', $cb_ptr_val;
    my ($cb_buf_ptr) = scalar_to_buffer($cb_buf);
    memcpy( $opts_ptr + PUSH_OPTS_CALLBACKS_OFFSET + CALLBACKS_CRED_OFFSET,
            $cb_buf_ptr, 8 );
    CORE::push @keep, \$cb_buf;
  }

  _install_certcheck( $opts_ptr, PUSH_OPTS_CALLBACKS_OFFSET, \@keep );

  if ($push_update_thunk) {
    my $ptr_val = Git::Libgit2::FFI::ffi->cast(
      'git_push_update_reference_cb' => 'opaque', $push_update_thunk,
    );
    my $buf = pack 'J', $ptr_val;
    my ($bp) = scalar_to_buffer($buf);
    memcpy( $opts_ptr + PUSH_OPTS_CALLBACKS_OFFSET
            + CALLBACKS_PUSH_UPDATE_REF_OFFSET, $bp, 8 );
    CORE::push @keep, \$buf;
  }

  return ( $opts_ptr, \@keep );
}

# Wrap a user coderef so it conforms to git_credential_acquire_cb.
# Returns ($closure, $keepalive). The closure must outlive the C call —
# the keepalive bundle is what the Remote method holds onto.
#
# NOTHING in here may die: the closure is called from libgit2's C frames,
# and a Perl exception unwinding across them is undefined behaviour. Every
# failure mode reports via warn and returns a negative rc, which libgit2
# propagates out of git_remote_fetch/push for check_rc to throw properly.
sub _make_credential_thunk {
  my ($user_cb) = @_;
  my $ffi = Git::Libgit2::FFI::ffi();

  my $closure = $ffi->closure(sub {
    my ( $out_ptr, $url, $username_from_url, $allowed_types, $payload ) = @_;
    my $cred = eval {
      $user_cb->(
        url                => $url,
        username_from_url  => $username_from_url,
        allowed_types      => $allowed_types,
      );
    };
    if ($@) {
      warn "credential callback died: $@";
      return -1;
    }
    return GIT_PASSTHROUGH unless defined $cred;
    unless ( Scalar::Util::blessed($cred)
             && $cred->isa('Git::Native::Credential') ) {
      warn "credentials callback must return a Git::Native::Credential "
         . "or undef, got " . _describe_value($cred) . "\n";
      return -1;
    }

    # Disown the wrapper — libgit2 takes ownership on return 0.
    my $cred_handle = $cred->_disown;

    # *out_ptr = cred_handle  (write 8 bytes of pointer to the address
    # the caller gave us)
    my $pkt = pack 'J', $cred_handle;
    my ($pkt_p) = scalar_to_buffer($pkt);
    memcpy( $out_ptr, $pkt_p, 8 );

    return 0;
  });

  # `sticky` would survive process-lifetime; we only need until the C
  # call returns, so just hand the closure to the caller's keepalive.
  return ( $closure, [ \$closure ] );
}

# Name a value for a diagnostic without ever dying on it — a blessed object
# may carry an overloaded (and throwing) stringifier, so report its class
# instead of interpolating it. Only used from inside FFI closures, where a
# die is not survivable.
sub _describe_value {
  my ($v) = @_;
  if ( my $class = Scalar::Util::blessed($v) ) { return "a $class object" }
  if ( my $type  = ref $v )                    { return "a $type reference" }
  my $str = "$v";
  $str = substr( $str, 0, 60 ) . '...' if length($str) > 63;
  return "the non-reference value '$str'";
}

# Build the update_tips closure (git_remote_callbacks.update_tips).
# Records each accepted ref update into the caller's $updated arrayref.
#
#   int cb(const char *refname, const git_oid *a, const git_oid *b, void *data)
#
# a is the old local tip; libgit2 passes a non-NULL pointer even when the
# ref didn't exist locally (the bytes are zero-filled — a zero SHA-1).
# We translate the all-zero "no previous ref" case to from => undef so
# callers can tell new-ref from same-oid updates without a magic constant.
# b is the new local tip, and is the all-zero oid when the ref was DELETED
# rather than moved — that is how a `prune => 1` fetch reports the refs it
# dropped (probed against a file:// remote). Same treatment: to => undef,
# which is also what the push side reports for a delete refspec, so
# `!defined $_->{to}` means "this ref is gone" on both operations.
#
# `reason` is always the empty string here: update_tips only fires for
# updates libgit2 accepted, and there is no server verdict on a fetch at all.
# It exists so a fetch entry and a push entry carry the identical key set —
# see Git::Native::Remote::Result.
#
# Returns 0 on success — returning non-zero aborts the fetch, which is what
# we want if libgit2 handed us something we cannot record (a NULL new tip),
# because the Result would otherwise lie by omission. Like every FFI closure
# here it must not let a die escape into libgit2's C frames, so the body runs
# under eval and reports via warn.
sub _make_update_tips_thunk {
  my ($updated) = @_;
  my $ffi = Git::Libgit2::FFI::ffi();
  my $closure = $ffi->closure(sub {
    my ( $refname, $a_ptr, $b_ptr, $payload ) = @_;

    my $ok = eval {
      die "update_tips callback got NULL b oid for ref '$refname'\n"
        unless $b_ptr;
      my $from = $a_ptr ? _oid_hex_if_nonzero($a_ptr) : undef;
      my $to   = _oid_hex_if_nonzero($b_ptr);
      CORE::push @$updated, {
        ref    => $refname,
        from   => $from,
        to     => $to,
        reason => '',
      };
      1;
    };

lib/Git/Native/Remote.pm  view on Meta::CPAN

      CORE::push @$updated, {
        ref    => $refname,
        from   => undef,
        to     => $targets->{$refname},
        reason => '',
      };
    }
    else {
      CORE::push @$rejected, { ref => $refname, reason => $status };
    }
    return 0;
  });
  return ( $closure, [ \$closure ] );
}

# Map each expanded push refspec's destination refname to the oid the push
# puts there, so a push update can report `to` the way a fetch update does.
# push_update_reference only hands us a per-ref verdict, but the source side
# of the refspec is a local ref we can just look up — no extra network.
#
# The value is undef for a delete refspec (`:refs/x`, which is what
# `prune => 1` emits) — matching the deleted-ref convention on the fetch
# side — and also undef for a source that is not a local reference (a raw
# oid, a shorthand, a ref that vanished between expansion and push).
sub _push_update_targets {
  my ( $self, $refspecs ) = @_;
  my %target;
  for my $rs (@$refspecs) {
    my ( $src, $dst );
    if ( index( $rs, ':' ) >= 0 ) {
      ( $src, $dst ) = $rs =~ /\A\+?([^:]*):(.*)\z/;
    }
    else {
      # A refspec without a colon pushes the source to the same name.
      ($src) = $rs =~ /\A\+?(.*)\z/;
      $dst = $src;
    }
    next unless defined $dst && length $dst;
    $target{$dst} = ( defined $src && length $src )
      ? $self->_local_oid_hex($src)
      : undef;
  }
  return \%target;
}

# Hex oid a local refname points at, or undef if it does not resolve to
# one. Goes through resolve so a symbolic source (`HEAD:refs/heads/main`)
# reports the oid it points at rather than nothing. Never dies: an
# unresolvable push source is a missing `to`, not a failed push.
sub _local_oid_hex {
  my ( $self, $refname ) = @_;
  my $oid = eval { $self->_owner->reference($refname)->resolve->target };
  return undef unless $oid;
  return $oid->hex;
}

# ---------- host-key verification (certificate_check callback) ----------

# Write a certificate_check closure into a callbacks struct. $cb_base is the
# offset of the embedded git_remote_callbacks within $struct_ptr (0 for a
# bare callbacks struct, 8 for fetch/push options). Pushes keepalives.
#
# libgit2 1.5.x + libssh2 has NO built-in known_hosts checking (that landed in
# 1.7). Without a certificate_check callback the ssh transport rejects every
# host with GIT_ECERTIFICATE (-17) "invalid or unknown remote ssh hostkey".
# So we always install one and verify the hostkey against ~/.ssh/known_hosts
# ourselves, mirroring what the `git` CLI does via OpenSSH.
sub _install_certcheck {
  my ( $struct_ptr, $cb_base, $keep ) = @_;
  my ( $thunk, $thunk_keep ) = _make_certcheck_thunk();
  CORE::push @$keep, @$thunk_keep;
  my $ptr_val = Git::Libgit2::FFI::ffi->cast(
    'git_transport_certificate_check_cb' => 'opaque', $thunk,
  );
  my $buf = pack 'J', $ptr_val;
  my ($bp) = scalar_to_buffer($buf);
  memcpy( $struct_ptr + $cb_base + CALLBACKS_CERTCHECK_OFFSET, $bp, 8 );
  CORE::push @$keep, \$buf;
  return;
}

# Build the certificate_check closure. Returns ($closure, $keepalive).
#
#   int cb(git_cert *cert, int valid, const char *host, void *payload)
#
# Return 0 to accept, <0 to reject (libgit2 aborts the connection with that
# code). For TLS (git_cert_x509) we honour libgit2's own `valid` flag so HTTPS
# remotes keep their normal CA validation. For SSH (git_cert_hostkey) we verify
# against known_hosts unless GIT_NATIVE_SSH_INSECURE is set (accept-all).
sub _make_certcheck_thunk {
  my $ffi = Git::Libgit2::FFI::ffi();
  my $closure = $ffi->closure(sub {
    my ( $cert_ptr, $valid, $host, $payload ) = @_;
    my $ok = eval {
      my $cert_type = unpack 'l', _peek_bytes( $cert_ptr, 4 );
      return $valid ? 1 : 0 if $cert_type == GIT_CERT_X509;
      if ( $cert_type == GIT_CERT_HOSTKEY_LIBSSH2 ) {
        return 1 if $ENV{GIT_NATIVE_SSH_INSECURE};
        return _verify_known_host( $cert_ptr, $host );
      }
      # Unknown cert kind — fall back to libgit2's own verdict.
      return $valid ? 1 : 0;
    };
    if ($@) {
      warn "Git::Native certificate check died: $@";
      return -1;
    }
    return $ok ? 0 : -1;
  });
  return ( $closure, [ \$closure ] );
}

# Verify an ssh hostkey against known_hosts using the SHA256 (preferred) or
# SHA1 fingerprint libssh2 computed for the negotiated key. Returns 1 on a
# match, 0 otherwise (with an actionable warning).
sub _verify_known_host {
  my ( $cert_ptr, $host ) = @_;
  my $bits = unpack 'l', _peek_bytes( $cert_ptr + CERT_HOSTKEY_TYPE_OFFSET, 4 );

  my ( $digest, $want );
  if ( $bits & GIT_CERT_SSH_SHA256 ) {
    $digest = 'sha256';
    $want   = _peek_bytes( $cert_ptr + CERT_HOSTKEY_SHA256_OFFSET, 32 );
  }
  elsif ( $bits & GIT_CERT_SSH_SHA1 ) {
    $digest = 'sha1';
    $want   = _peek_bytes( $cert_ptr + CERT_HOSTKEY_SHA1_OFFSET, 20 );
  }
  else {
    warn "Git::Native: ssh hostkey for '$host' offers no SHA1/SHA256 "
       . "fingerprint to verify; rejecting\n";
    return 0;
  }

  my ( $matched, $host_seen ) = _known_hosts_match( $host, $digest, $want );
  return 1 if $matched;

  if ($host_seen) {
    warn "Git::Native: ssh hostkey for '$host' did NOT match the "
       . "$host_seen known_hosts entr" . ( $host_seen == 1 ? 'y' : 'ies' )
       . " for it — server offered a key type you have not cached, or the "
       . "key changed. Run `ssh-keyscan $host >> ~/.ssh/known_hosts`, or set "