App-karr
view release on metacpan or search on metacpan
ENV GIT_AUTHOR_EMAIL="karr@localhost"
ENV GIT_COMMITTER_NAME="karr"
ENV GIT_COMMITTER_EMAIL="karr@localhost"
WORKDIR /work
FROM runtime-base AS runtime-root
COPY docker/karr-entrypoint.sh /usr/local/bin/karr-entrypoint.sh
RUN chmod +x /usr/local/bin/karr-entrypoint.sh
ENTRYPOINT ["karr-entrypoint.sh"]
FROM runtime-base AS runtime-user
ARG KARR_UID=1000
ARG KARR_GID=1000
RUN groupadd -g ${KARR_GID} karr \
&& useradd -m -d /home/karr -u ${KARR_UID} -g ${KARR_GID} -s /bin/sh karr \
t/120-error-message-sweep.t view on Meta::CPAN
my $r = run_karr( $repo, 'init' );
die "karr init failed: $r->{stderr}" unless $r->{exit} == 0;
return $repo;
}
# An unwritable directory inside $parent, or a skip reason.
sub unwritable_dir {
my ($parent) = @_;
my $dir = path($parent)->child('locked');
$dir->mkpath;
chmod 0500, "$dir" or return;
return $dir;
}
my $ROOT_USER = ( $> == 0 );
# ---------------------------------------------------------------------------
subtest 'karr outside a git repository says so and nothing else' => sub {
my $nowhere = tempdir( CLEANUP => 1 );
my $r = run_karr( $nowhere, 'list' );
t/120-error-message-sweep.t view on Meta::CPAN
unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
or diag "stderr was:\n$r->{stderr}";
unlike $r->{stderr}, qr/Restore\.pm/, 'no karr module path'
or diag "stderr was:\n$r->{stderr}";
};
subtest 'karr backup reports an --output it cannot write' => sub {
plan skip_all => 'running as root: an unwritable directory is still writable'
if $ROOT_USER;
my $repo = new_board();
my $dir = unwritable_dir($repo) or plan skip_all => "cannot chmod: $!";
my $target = $dir->child('backup.yml');
my $r = run_karr( $repo, 'backup', '--output', "$target" );
chmod 0700, "$dir";
isnt $r->{exit}, 0, 'the backup fails';
like $r->{stderr}, qr/Could not write \Q$target\E/, 'the target is named';
like $r->{stderr}, qr/Permission denied/, 'the reason survives';
unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
or diag "stderr was:\n$r->{stderr}";
unlike $r->{stderr}, qr/Backup\.pm/, 'no karr module path'
or diag "stderr was:\n$r->{stderr}";
};
subtest 'karr context --write reports an unwritable parent directory' => sub {
plan skip_all => 'running as root: an unwritable directory is still writable'
if $ROOT_USER;
my $repo = new_board();
my $dir = unwritable_dir($repo) or plan skip_all => "cannot chmod: $!";
my $target = $dir->child('context.md');
my $r = run_karr( $repo, 'context', '--write-to', "$target" );
chmod 0700, "$dir";
isnt $r->{exit}, 0, 'the write fails';
like $r->{stderr}, qr/Could not write \Q$target\E/, 'the target is named';
like $r->{stderr}, qr/Permission denied/, 'the reason survives';
unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
or diag "stderr was:\n$r->{stderr}";
unlike $r->{stderr}, qr/Context\.pm/, 'no karr module path'
or diag "stderr was:\n$r->{stderr}";
};
subtest 'karr context --write still overwrites a read-only target file' => sub {
plan skip_all => 'running as root: a read-only file is still writable'
if $ROOT_USER;
# Named in ticket #77 as the case that must NOT start failing: spew renames
# a temp file into place, so the mode of the existing file is irrelevant --
# only the directory has to be writable. Guarding the write must not turn
# this into an error.
my $repo = new_board();
my $target = path($repo)->child('ctx.md');
$target->spew_utf8("previous content\n");
chmod 0400, "$target" or plan skip_all => "cannot chmod: $!";
my $r = run_karr( $repo, 'context', '--write-to', "$target" );
is $r->{exit}, 0, 'the write succeeds' or diag "stderr was:\n$r->{stderr}";
like $target->slurp_utf8, qr/kanban-md context/, 'and the context really landed';
};
subtest 'karr init --claude-skill reports an unwritable .claude' => sub {
plan skip_all => 'running as root: an unwritable directory is still writable'
if $ROOT_USER;
my $repo = tempdir( CLEANUP => 1 );
system( 'git', 'init', '-q', $repo ) == 0 or die 'git init failed';
system( 'git', '-C', $repo, 'config', 'user.email', 'test@example.com' );
system( 'git', '-C', $repo, 'config', 'user.name', 'Test User' );
my $claude = path($repo)->child('.claude');
$claude->mkpath;
chmod 0500, "$claude" or plan skip_all => "cannot chmod: $!";
my $r = run_karr( $repo, 'init', '--claude-skill' );
chmod 0700, "$claude";
isnt $r->{exit}, 0, 'the install fails';
like $r->{stderr}, qr/Could not create /, 'karr says what it could not do';
like $r->{stderr}, qr/Permission denied/, 'the reason survives';
unlike $r->{stderr}, qr/ at \S+ line \d+/, 'no source location'
or diag "stderr was:\n$r->{stderr}";
unlike $r->{stderr}, qr/Init\.pm/, 'no karr module path'
or diag "stderr was:\n$r->{stderr}";
};
t/144-skill-write-in-place.t view on Meta::CPAN
is( $chained->slurp_utf8, $NEW, 'and the hardlink to that target sees it too' );
};
subtest 'a read-only target is still updated, and a broken chain is reported' => sub {
plan skip_all => 'running as root: a read-only file is still writable'
if $> == 0;
my $dir = tempdir( CLEANUP => 1 );
my ( $primary, $secondary ) = linked_pair( $dir, $OLD );
plan skip_all => 'filesystem does not support hardlinks' unless $primary;
chmod 0444, "$primary" or plan skip_all => "cannot chmod the target: $!";
plan skip_all => 'the target is writable despite mode 0444' if -w "$primary";
my $before = ident($primary);
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, $_[0] };
App::karr::Cmd::Skill->new->_write_skill( $primary, $NEW );
# Before the fix this case worked (the rename only needs a writable
# directory), so it keeps working -- but it is now the one path where the
# chain cannot survive, and that is said out loud rather than done quietly.
is( $primary->slurp_utf8, $NEW, 'the read-only target was updated, as it was before' );
isnt( ident($primary)->{ino}, $before->{ino}, 'by replacement: in-place was impossible here' );
is( $secondary->slurp_utf8, $OLD, 'so the other link is left on the old content' );
is( scalar(@warnings), 1, 'exactly one warning' ) or diag "warnings emitted: @warnings";
like( $warnings[0], qr/could not be written in place/, 'it says the write was not in place' );
like( $warnings[0], qr/hardlink/, 'and that a hardlink is affected' );
unlike( $warnings[0], qr/ at \S+ line \d+/, 'no karr source location in it' )
or diag "warning was: $warnings[0]";
chmod 0644, "$primary", "$secondary";
};
subtest 'a read-only target with no other links warns about nothing' => sub {
plan skip_all => 'running as root: a read-only file is still writable'
if $> == 0;
my $dir = tempdir( CLEANUP => 1 );
my $file = path($dir)->child('SKILL.md');
$file->spew_utf8($OLD);
chmod 0444, "$file" or plan skip_all => "cannot chmod the target: $!";
plan skip_all => 'the target is writable despite mode 0444' if -w "$file";
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, $_[0] };
App::karr::Cmd::Skill->new->_write_skill( $file, $NEW );
is( $file->slurp_utf8, $NEW, 'still updated' );
is( scalar(@warnings), 0, 'no chain to break, so no noise' )
or diag "warnings emitted: @warnings";
chmod 0644, "$file";
};
subtest 'an unwritable directory is still a clean one-line error' => sub {
plan skip_all => 'running as root: an unwritable directory is still writable'
if $> == 0;
my $dir = tempdir( CLEANUP => 1 );
my $sub = path($dir)->child('skills');
$sub->mkpath;
chmod 0500, "$sub" or plan skip_all => "cannot chmod the directory: $!";
my $err = do {
local $@;
eval { App::karr::Cmd::Skill->new->_write_skill( $sub->child('SKILL.md'), $NEW ); 1 };
$@;
};
chmod 0700, "$sub";
like( $err, qr/^Could not write /, 'reported as a write failure (ticket #77 wording kept)' );
like( $err, qr/Permission denied/, 'with the reason from the OS' );
unlike( $err, qr/ at \S+ line \d+/, 'and no source location' ) or diag "error was: $err";
my @lines = split /\n/, $err;
is( scalar(@lines), 1, 'exactly one line' ) or diag "error was: $err";
};
subtest 'karr skill install/update through the real CLI keep the inode' => sub {
my $dir = tempdir( CLEANUP => 1 );
t/146-init-skill-write-in-place.t view on Meta::CPAN
is( ident($installed)->{nlink}, 1, 'one link, as a fresh file should have' );
};
subtest 'a read-only installed skill is still updated, and a broken chain is reported' => sub {
plan skip_all => 'running as root: a read-only file is still writable'
if $> == 0;
my $dir = tempdir( CLEANUP => 1 );
my ( $installed, $elsewhere ) = chained_install( $dir, $OLD );
plan skip_all => 'filesystem does not support hardlinks' unless $installed;
chmod 0444, "$installed" or plan skip_all => "cannot chmod the target: $!";
plan skip_all => 'the target is writable despite mode 0444' if -w "$installed";
my $before = ident($installed);
my $r = install_into( $dir, $NEW );
chmod 0644, "$installed", "$elsewhere";
# Before the fix this case worked (the rename only needs a writable
# directory), so it keeps working -- but it is the one path where the chain
# cannot survive, and that is said out loud rather than done quietly.
is( $r->{error}, '', 'the install still succeeds' );
is( $installed->slurp_utf8, $NEW, 'the read-only target was updated, as it was before' );
isnt( ident($installed)->{ino}, $before->{ino}, 'by replacement: in-place was impossible here' );
is( $elsewhere->slurp_utf8, $OLD, 'so the other link is left on the old content' );
is( scalar( @{ $r->{warnings} } ), 1, 'exactly one warning' )
t/146-init-skill-write-in-place.t view on Meta::CPAN
subtest 'an unwritable .claude is still the one-line error of ticket #77' => sub {
plan skip_all => 'running as root: an unwritable directory is still writable'
if $> == 0;
# t/120-error-message-sweep.t pins this end to end; repeated here because
# routing the write through the shared role is exactly the change that could
# have swapped this message for the role's own "Could not write ...".
my $dir = tempdir( CLEANUP => 1 );
my $claude = path($dir)->child('.claude');
$claude->mkpath;
chmod 0500, "$claude" or plan skip_all => "cannot chmod the directory: $!";
my $r = install_into( $dir, $NEW );
chmod 0700, "$claude";
like( $r->{error}, qr/^Could not create /, 'the directory is what karr could not make' );
like( $r->{error}, qr/Permission denied/, 'with the reason from the OS' );
unlike( $r->{error}, qr/ at \S+ line \d+/, 'and no source location' )
or diag "error was: $r->{error}";
my @lines = split /\n/, $r->{error};
is( scalar(@lines), 1, 'exactly one line' ) or diag "error was: $r->{error}";
};
subtest 'karr init --claude-skill through the real CLI keeps the inode' => sub {
t/151-foundation-shell-expansion.t view on Meta::CPAN
subtest 'the synthesized claude command hands the prompt over as one argument'
=> sub {
my $bin_dir = tempdir( CLEANUP => 1 );
my $bin = $bin_dir->child('fake-claude');
$bin->spew_utf8( <<'SH' );
#!/bin/sh
printf 'argc=%s\n' "$#"
for a in "$@"; do printf 'arg=[%s]\n' "$a"; done
SH
chmod 0755, "$bin" or die "chmod $bin: $!";
my $repo = tempdir( CLEANUP => 1 );
$repo->child('globbed.txt')->spew_utf8('x'); # something for * to catch
my $ran = $repo->child('RAN');
# Everything a Markdown prompt throws at a shell: a glob, a backtick span,
# word-splitting whitespace, a metacharacter and an apostrophe.
my $prompt = "Pick * next; run `touch $ran`, mind the spaces, don't quote";
my $karr = {
t/74-cli-transport-robustness.t view on Meta::CPAN
# Both are driven with a fake `git` on PATH, so they are deterministic and do
# not depend on board size or network conditions.
# Write an executable fake `git` (a Perl script, for portable signal control)
# into its own directory and return that directory.
sub fake_git {
my ($body) = @_;
my $bin = tempdir( CLEANUP => 1 );
my $exe = path( $bin, 'git' );
$exe->spew_utf8("#!$^X\nuse strict;\nuse warnings;\n$body");
chmod 0755, "$exe" or die "chmod: $!";
return $bin;
}
sub repo_with_remote {
my $work = tempdir( CLEANUP => 1 );
system( 'git', 'init', '-q', '--bare', "$work/origin.git" );
system("git clone -q '$work/origin.git' '$work/a' 2>/dev/null");
system( 'git', '-C', "$work/a", 'config', 'user.email', 'a@karr.test' );
system( 'git', '-C', "$work/a", 'config', 'user.name', 'agent-a' );
return ( $work, App::karr::Git->new( dir => "$work/a" ) );
t/78-push-rejection.t view on Meta::CPAN
# A bare origin whose pre-receive hook declines everything, plus a clone with a
# board written into refs/karr/* and nothing pushed yet.
sub protected_remote {
my (%opt) = @_;
my $work = tempdir( CLEANUP => 1 );
system( 'git', 'init', '-q', '--bare', "$work/origin.git" );
if ( $opt{hook} ) {
my $hook = path("$work/origin.git/hooks/pre-receive");
$hook->spew("#!/bin/sh\necho 'board is protected' >&2\nexit 1\n");
chmod 0755, "$hook";
}
system("git clone -q '$work/origin.git' '$work/a' 2>/dev/null");
system( 'git', '-C', "$work/a", 'config', 'user.email', 'a@karr.test' );
system( 'git', '-C', "$work/a", 'config', 'user.name', 'agent-a' );
my $git = App::karr::Git->new( dir => "$work/a" );
$git->write_ref( 'refs/karr/config', "board:\n name: demo\n" );
$git->save_task_ref( task( 1, 'One' ) );
return ( $work, $git );
}
t/78-push-rejection.t view on Meta::CPAN
waitpid $pid, 0;
}
return ();
}
subtest 'native, end to end: a real receive-pack rejection fails the push' => sub {
my $work = tempdir( CLEANUP => 1 );
system( 'git', 'init', '-q', '--bare', "$work/origin.git" );
my $hook = path("$work/origin.git/hooks/pre-receive");
$hook->spew("#!/bin/sh\necho 'board is protected' >&2\nexit 1\n");
chmod 0755, "$hook";
path("$work/origin.git/git-daemon-export-ok")->spew('');
my ( $pid, $port ) = start_daemon($work);
plan skip_all => 'no git daemon on a loopback port here' unless $pid;
$DAEMON_PID = $pid;
system("git clone -q 'git://127.0.0.1:$port/origin.git' '$work/a' 2>/dev/null");
system( 'git', '-C', "$work/a", 'config', 'user.email', 'a@karr.test' );
system( 'git', '-C', "$work/a", 'config', 'user.name', 'agent-a' );
t/81-error-messages.t view on Meta::CPAN
is clean_error($obj), 'libgit2 style message', 'an object with ->message is read through it';
};
subtest 'karr skill install reports an unwritable target without a source location' => sub {
plan skip_all => 'running as root: an unwritable directory is still writable'
if $> == 0;
my $ROOT = abs_path('.');
my $home = tempdir( CLEANUP => 1 );
path($home)->child('.claude/skills')->mkpath;
chmod 0500, path($home)->child('.claude/skills')->stringify
or plan skip_all => "cannot chmod the target directory: $!";
my $old = getcwd();
chdir $home or die "chdir $home: $!";
my $errfh = gensym;
my $pid = open3( undef, my $outfh, $errfh,
$^X, "-I$ROOT/lib", "$ROOT/bin/karr", 'skill', 'install', '--agent', 'claude-code' );
my $out = do { local $/; <$outfh> };
my $err = do { local $/; <$errfh> };
waitpid( $pid, 0 );
my $exit = $? >> 8;
chdir $old or die "chdir $old: $!";
chmod 0700, path($home)->child('.claude/skills')->stringify;
isnt $exit, 0, 'the failed install is reported as a failure';
like $err, qr/Could not write /, 'stderr says what karr could not do';
like $err, qr/Permission denied/, 'and keeps the reason from the OS';
unlike $err, qr/ at \S+ line \d+/, 'no "at FILE line N." suffix'
or diag "stderr was:\n$err";
unlike $err, qr/Skill\.pm/, 'no karr module path leaks'
or diag "stderr was:\n$err";
my @lines = split /\n/, $err;
is scalar(@lines), 1, 'exactly one line of error'
t/93-syncguard-push-rejection.t view on Meta::CPAN
system( 'git', '-C', "$work/a", 'config', 'user.name', 'agent-a' );
is run_karr( "$work/a", 'init', '--name', 'Demo' )->{exit}, 0,
'setup: the board is created and pushed';
is run_karr( "$work/a", 'create', 'task one' )->{exit}, 0,
'setup: and carries a task';
# Only now does the server start refusing.
my $hook = path("$work/origin.git/hooks/pre-receive");
$hook->spew("#!/bin/sh\necho 'board is protected' >&2\nexit 1\n");
chmod 0755, "$hook";
# Writes task 1, then dies on the missing 999 -- so the push happens from
# the END-block flush, with no sync_after ever reached.
my $r = run_karr( "$work/a", 'move', '1,999', 'in-progress',
'--claim', 'flush-agent' );
is $r->{exit}, 1, 'the command still fails on its own error';
like $r->{stderr}, qr/Task 999 not found/,
'and that error still reaches the user';
( run in 2.282 seconds using v1.01-cache-2.11-cpan-6736b670a1e )