App-karr
view release on metacpan or search on metacpan
lib/App/karr/Git.pm view on Meta::CPAN
# Reached only when libgit2 could not answer -- an index it refuses to
# read, or a Git::Native older than the `index` accessor. `git ls-files`
# reads the same index and matches a bare directory name as a prefix over
# everything under it, so it answers the same question for a file or a
# directory alike -- and $rel is a root-relative pathspec, which is why
# _run_git resolves it from the work tree root rather than from ->dir.
# Without a `git` on PATH there is nothing left to ask, and an unanswered
# question is reported as "not tracked" -- the same
# not-tracked-as-far-as-we-can-tell that is_tracked returns for a
# repository it cannot open.
my $run = $self->_run_git( 'ls-files', '-z', '--', $rel );
return 0 unless $run->{failure} eq '' && ( $run->{status} >> 8 ) == 0;
return length $run->{out} ? 1 : 0;
}
# ----- User identity (read via native config, not via CLI) -----
sub _config_string {
my ( $self, $key ) = @_;
my $repo = $self->_repo or return '';
my $val = try { $repo->config_string($key) } catch { undef };
return defined $val ? from_octets($val) : '';
}
sub git_user_email {
my ($self) = @_;
return $self->_config_string('user.email');
}
sub git_user_name {
my ($self) = @_;
return $self->_config_string('user.name');
}
sub git_user_identity {
my ($self) = @_;
my $name = $self->git_user_name;
my $email = $self->git_user_email;
return "$name <$email>" if $name && $email;
return $email || $name || '';
}
# ----- Ref name validation -----
sub normalize_ref_name {
my ( $self, $ref ) = @_;
defined $ref or die "Ref name is required\n";
$ref =~ s{^/+}{};
return $ref =~ m{^refs/} ? $ref : "refs/$ref";
}
sub validate_helper_ref {
my ( $self, $ref ) = @_;
my $full_ref = $self->normalize_ref_name($ref);
my @blocked = (
'refs/heads/',
'refs/tags/',
'refs/remotes/',
'refs/bisect/',
'refs/replace/',
'refs/karr/',
# Pick locks (App::karr::Lock). They were moved out of refs/karr/ so
# that no refspec could publish them (#93); `karr set-refs` names a ref
# and pushes it, so leaving it able to reach them would put the same
# hole back one command over.
'refs/karr-local/',
);
for my $prefix (@blocked) {
die "Ref '$full_ref' is in a protected namespace\n"
if index( $full_ref, $prefix ) == 0;
}
die "Ref '$full_ref' is in a protected namespace\n"
if $full_ref eq 'refs/stash' || index( $full_ref, 'refs/stash/' ) == 0;
# Native validity check via Git::Native.
die "Ref '$full_ref' is not a valid git ref name\n"
unless Git::Native->reference_name_is_valid($full_ref);
return $full_ref;
}
# ----- Ref CRUD (the hotspot — was 4 fork/exec per write_ref) -----
# How many times a contended ref write is re-attempted before karr gives up,
# and the backoff between attempts. Contention here is measured in the time it
# takes libgit2 to take refs/<name>.lock, write and rename -- microseconds --
# so a few milliseconds of randomised sleep is enough to break up a pile-up.
# The randomisation is the point: a fixed delay makes every loser wake up
# together and collide again.
#
# Bounded on purpose. karr is driven by unattended agents, and a write loop
# that can spin forever on a genuinely wedged ref is worse than one that fails
# with something the agent can report.
use constant CAS_ATTEMPTS => 32;
use constant CAS_BACKOFF_STEP => 0.001; # seconds, times the attempt number
use constant CAS_BACKOFF_CAP => 0.010; # ...but never longer than this
use constant CAS_BACKOFF_JITTER => 0.005;
# Run $attempt until it commits to an answer, with backoff in between.
#
# $attempt returns the empty list to mean "another writer got in first, read
# again and retry"; any other return value is the final answer and comes back
# to the caller untouched (in list context as the list it returned). Anything
# it dies with propagates immediately -- a real failure is not retried.
#
# Every compare-and-swap caller goes through here, so the rules for what counts
# as contention live in exactly one place (see _is_contended_ref_error).
sub retry_contended {
my ( $self, $what, $attempt ) = @_;
for my $try ( 1 .. CAS_ATTEMPTS ) {
my @answer = $attempt->($try);
return wantarray ? @answer : $answer[0] if @answer;
_cas_backoff($try);
}
die "karr: gave up updating $what after " . CAS_ATTEMPTS
. " attempts -- too many agents are writing the board at once. "
. "Try again.\n";
}
sub _cas_backoff {
my ($try) = @_;
my $step = CAS_BACKOFF_STEP * $try;
$step = CAS_BACKOFF_CAP if $step > CAS_BACKOFF_CAP;
Time::HiRes::sleep( $step + rand CAS_BACKOFF_JITTER );
return;
}
lib/App/karr/Git.pm view on Meta::CPAN
};
return 0 unless $deleted;
$WRITES++;
return 1;
}
# Two answers from one read: the OID the ref points at (undef when the ref is
# absent) and the content of that exact commit. Compare-and-swap callers need
# both together -- deciding on content fetched independently of the OID would
# guard the write against the wrong revision.
sub read_ref_with_oid {
my ( $self, $ref ) = @_;
my $repo = $self->_repo or return ( undef, '' );
# Ask whether the ref is there before looking it up. Letting Git::Native
# throw for a miss would build a full Throwable stack trace, and this runs
# once per task load.
return ( undef, '' ) unless $repo->reference_exists($ref);
my $oid = try { $repo->reference($ref)->target } catch { undef };
return ( undef, '' ) unless $oid;
my $content = try {
my $commit = $repo->commit($oid);
my $tree = $commit->tree;
my $entry = $tree->entry_by_name('data');
return '' unless $entry;
return $repo->blob( $entry->{oid} )->content;
} catch { '' };
$content = from_octets($content);
# Match historical CLI behaviour: cat-file's trailing newline was chomped.
chomp $content if defined $content;
return ( $oid->hex, $content );
}
sub read_ref {
my ( $self, $ref ) = @_;
return ( $self->read_ref_with_oid($ref) )[1];
}
sub ref_exists {
my ( $self, $ref ) = @_;
my $repo = $self->_repo or return 0;
return $repo->reference_exists($ref) ? 1 : 0;
}
# Returns 1 when this call removed the ref and 0 when there was nothing to
# remove. It used to swallow the exception and answer 1 regardless (#51), which
# made a delete that did nothing look like a delete that worked, and bumped
# $WRITES either way. That counter is what SyncGuard reads to decide whether
# local refs still need pushing, so it may only ever count writes that landed.
#
# A delete that was attempted and refused dies, as every other ref mutation in
# this class does. It used to answer 0 for that too -- the same 0 as "was never
# there" -- and break_lock read that 0 as "gone", so `karr unlock` reported
# "Broke lock on task N" over a lock that was still standing (#119). unlock is
# the escape hatch for a holder that never came back; a false success there
# leaves the card locked for everyone with nobody left to look.
#
# 0 therefore means "the ref is not on this board", never "we could not tell".
# The one seam is an unopenable repository, which is not a refusal to delete
# but the whole class degrading to no-ops -- during global destruction _repo is
# false by design and nothing native may run or throw (#63).
#
# Contention retries on the same terms as write_ref: losing the race for
# refs/<name>.lock is not a failed delete, it is one that has not been
# attempted yet.
sub delete_ref {
my ( $self, $ref ) = @_;
my $repo = $self->_repo or return 0;
return $self->retry_contended( "ref $ref", sub {
# Asking first keeps "nothing to delete" -- a no-op, not a write --
# apart from the failure below, which libgit2 reports the same way.
return 0 unless $repo->reference_exists($ref);
my $deleted = try {
$repo->reference_delete($ref);
1;
} catch {
my $err = $_;
return 0 if _is_contended_ref_error( $err, 0 );
die _ref_error( 'delete', $ref, $err );
};
return () unless $deleted;
$WRITES++;
return 1;
} );
}
# ----- Remote / network ops: native via Git::Native::Remote -----
# The push refspec. Forced, because write_ref builds every board commit with
# `parents => []`: no board ref update is ever a fast-forward, so a non-forced
# refspec can never apply one. push has always been forced; pull was not, and
# libgit2 declines a non-ff fetch update without raising an error, so pull
# returned success while leaving the ref stale -- and the next push then
# force-wrote that stale ref over the other agent's work (#40). Both
# directions are forced now; see _fetch_refspec for the pull side.
#
# The semantics this settles on are last-writer-wins, which is what the
# parentless-commit design already implied everywhere else. Doing better
# would need compare-and-swap on the ref (git_reference_create_matching,
# unbound in Git::Libgit2 -- see ticket #81) plus per-ref rejection reporting
# from libgit2's update_tips/push_update_reference callbacks (not installed
# by Git::Native -- ticket #80). Neither is reachable from karr today.
use constant BOARD_REFSPEC => '+refs/karr/*:refs/karr/*';
use constant BOARD_ROOT => 'refs/karr/';
# The board's identity (#95): stamped once at board birth, compared on every
# pull before any reconciliation -- see _check_board_identity. Declared with
# the other namespace constants because use constant is only visible from its
# textual point on, and _check_board_identity needs it.
use constant BOARD_ID_REF => 'refs/karr/meta/board-id';
# Remote-tracking mirror: refs/karr-remote/<remote>/<X> holds the remote's
lib/App/karr/Git.pm view on Meta::CPAN
my @rejected;
for my $line ( split /\n/, $out // '' ) {
next unless $line =~ /\A!\t([^\t]*)\t(.*)\z/;
my ( $refspec, $summary ) = ( $1, $2 );
# "<src>:<dst>", and <src> is empty for a delete. The board ref is the
# destination either way.
my $ref = $refspec =~ /:([^:]*)\z/ ? $1 : $refspec;
my $reason = $summary =~ /\(([^)]*)\)\s*\z/ ? $1 : $summary;
CORE::push @rejected, { ref => $ref, reason => $reason };
}
return \@rejected;
}
# Everything that is not a rejection line and not git's own "To <url>" /
# "Done" framing was a ref the server took, which is what turns the message
# into "rejected 2 of 5" instead of a bare list.
sub _count_push_porcelain_accepted {
my ($out) = @_;
my $accepted = 0;
for my $line ( split /\n/, $out // '' ) {
next unless $line =~ /\A([ +\-*=!])\t[^\t]*\t/;
$accepted++ unless $1 eq '!';
}
return $accepted;
}
# Wall-clock budget for one `git` CLI run, in seconds. 0 (or a non-numeric
# value) disables it. karr is driven by unattended agents, so the default is a
# ceiling rather than a guess at how slow a legitimate transfer may be.
use constant DEFAULT_TRANSPORT_TIMEOUT => 120;
# Cap on how much of each stream is kept. Draining continues past it -- the
# point is only to stop a runaway git from being buffered into memory whole.
use constant CLI_OUTPUT_LIMIT => 65_536;
sub _transport_timeout {
my $raw = $ENV{KARR_TRANSPORT_TIMEOUT};
return DEFAULT_TRANSPORT_TIMEOUT
unless defined $raw && $raw =~ /\A\d+(?:\.\d+)?\z/;
return $raw + 0;
}
# Run `git -C <work tree root> @args` and return
# { ok => 0|1, failure => ''|'start'|'timeout', status => $?, out, err,
# timeout => $seconds }
#
# The root, not ->dir. Everything this class hands git as a path comes out of
# _relative_to_root and is therefore measured from the work tree root, while a
# git pathspec is resolved against the process cwd -- so running from ->dir
# asked about `subdir/tasks` whenever ->dir was not the root, and `git ls-files`
# answers that with exit 0 and no output, i.e. "not tracked" (#113). Pinning
# the cwd here puts both routes on one origin instead of correcting the
# pathspec at each call site. It costs the transport verbs nothing: git
# discovers the same repository from either directory. Only a repository
# libgit2 cannot open has no root to run from, and there ->dir is all that is
# left -- the same degradation every other native operation makes.
#
# Both pipes are drained through one IO::Select loop. Reading stdout to EOF
# first, as this used to, deadlocks the moment the child fills the 64 KiB
# stderr pipe buffer: the child blocks on write and so never exits or closes
# stdout, while the parent is still blocked reading stdout. A diverged board
# reaches that at roughly 700 rejected refs, and it could strike inside
# bin/karr's END flush, i.e. after the command had already printed its result
# (#43). The loop is also bounded by a deadline, so a transport that stalls
# (an ssh ProxyCommand hanging on a jump host, a grandchild holding the pipes
# open past the child's exit) fails instead of hanging an unattended agent.
#
# `status` is the raw waitpid status, not `$? >> 8`, so callers can tell a
# clean exit from a death by signal (#42).
sub _run_git {
my ( $self, @args ) = @_;
my $cwd = $self->repo_root // $self->dir;
my @cmd = ( 'git', '-C', $cwd->stringify, @args );
my $timeout = _transport_timeout();
my %result = (
ok => 0, failure => 'start', status => 0,
out => '', err => '', timeout => $timeout,
);
my ( $pid, $timed_out );
my $started = try {
local $ENV{GIT_TERMINAL_PROMPT} = 0; # never hang on an interactive prompt
my $err_fh = gensym;
$pid = open3( my $in, my $out_fh, $err_fh, @cmd );
close $in;
my %sink = (
fileno($out_fh) => \$result{out},
fileno($err_fh) => \$result{err},
);
my $select = IO::Select->new( $out_fh, $err_fh );
my $deadline = $timeout ? Time::HiRes::time() + $timeout : undef;
while ( $select->count ) {
my $left = defined $deadline
? $deadline - Time::HiRes::time() : undef;
if ( defined $left && $left <= 0 ) { $timed_out = 1; last }
# Poll in slices so the deadline is still honoured while git is
# quiet on both streams.
my $slice = !defined $left || $left > 1 ? 1 : $left;
for my $fh ( $select->can_read($slice) ) {
my $read = sysread $fh, my $chunk, 65_536;
if ( !defined $read ) {
next if $! == EINTR;
$select->remove($fh);
next;
}
if ( !$read ) { $select->remove($fh); next }
my $buffer = $sink{ fileno($fh) };
$$buffer .= $chunk if length($$buffer) < CLI_OUTPUT_LIMIT;
}
}
1;
} catch {
$result{err} = "$_";
0;
};
return \%result unless $started;
if ($timed_out) {
( run in 1.711 second using v1.01-cache-2.11-cpan-788537b7465 )