view release on metacpan or  search on metacpan

t/210-foundation-coordinator.t  view on Meta::CPAN

  my $file = $dir->child('config.yml');
  $file->spew_utf8( YAML::XS::Dump( \%data ) );
  return $file;
}

sub write_assignment {
  my ( $cfg, $data ) = @_;
  path($cfg)->sibling('assignment.yml')->spew_utf8( YAML::XS::Dump($data) );
  return;
}

sub set_agents_state {
  my ( $cfg, $data ) = @_;
  path($cfg)->sibling('agents.state')->spew_utf8( json_encode($data) );
  return;
}

# Never undef and never a nested deref on a missing key: a mutation that
# stops recording availability must FAIL a test, not die before it runs one.
sub agents_state {
  my ( $cfg ) = @_;
  my $file = path($cfg)->sibling('agents.state');
  return {} unless $file->exists;
  my $data = json_decode( $file->slurp_utf8 );
  return ref $data eq 'HASH' ? $data : {};
}

sub agent_record {
  my ( $cfg, $name ) = @_;
  return agents_state($cfg)->{$name} // {};
}

my @ALIVE;    # collaborators hold their foundation weakly
sub foundation {
  my ( $cfg, %args ) = @_;
  my $f = App::karr::Foundation->new( config => "$cfg", %args );
  push @ALIVE, $f;
  return $f;
}

sub coordinator { return foundation(@_)->_coordinator }

# STDOUT through a real file, not an in-memory scalar: the runner forks and
# dups the child's stdout onto a pipe, and a scalar filehandle has no
# descriptor to dup onto.
sub capture {
  my ( $code ) = @_;
  my $file = Path::Tiny->tempfile;
  open my $save, '>&', \*STDOUT or die "dup stdout: $!";
  open STDOUT, '>', "$file"     or die "redirect stdout: $!";
  binmode STDOUT, ':encoding(UTF-8)';
  my ( $ret, $err );
  eval { $ret = $code->(); 1 } or $err = $@;
  open STDOUT, '>&', $save or die "restore stdout: $!";
  close $save;
  die $err if defined $err;
  return ( $file->slurp_utf8, $ret );
}

# The fake coordination agent. It records what it was given -- its argv (so
# the kind: claude-code contract is visible), the prompt the shell expanded
# for it, its role and its working directory -- and can be told to fail or to
# leave a result object behind.
my $OUT;    # where the fake records, set per subtest
sub write_coordinator {
  my ( $dir ) = @_;
  my $script = path($dir)->child('fake-coordinator.pl');
  $script->spew_utf8(<<'PERL');
use strict;
use warnings;
use Path::Tiny qw( path );
my $out = path( $ENV{FAKE_OUT} or die "no FAKE_OUT\n" );
$out->mkpath unless $out->is_dir;
$out->child('runs')->append_utf8("run\n");
my ( $p ) = grep { $ARGV[$_] eq '-p' } 0 .. $#ARGV;
$out->child('prompt')->spew_utf8( defined $p ? ( $ARGV[ $p + 1 ] // '' ) : '' );
$out->child('argv')->spew_utf8( join "\n", @ARGV );
$out->child('env')->spew_utf8( join "\n",
  'role=' . ( $ENV{KARR_ROLE} // '' ),
  'task=' . ( $ENV{KARR_TASK} // '' ),
  'cwd='  . path('.')->realpath );
print "$ENV{FAKE_RESULT}\n" if defined $ENV{FAKE_RESULT} && length $ENV{FAKE_RESULT};
exit( $ENV{FAKE_EXIT} // 0 );
PERL
  return qq{$^X -I"$LIB" "$script"};
}

sub fake_out {
  my $dir = tempdir( CLEANUP => 1 );
  push @KEEP, $dir;
  $OUT = $dir;
  $ENV{FAKE_OUT} = "$dir";
  return $dir;
}

sub coordinator_runs {
  my $f = $OUT->child('runs');
  return $f->exists ? ( grep { length } split /\n/, $f->slurp_utf8 ) : ();
}

sub coordinator_prompt {
  my $f = $OUT->child('prompt');
  return $f->exists ? $f->slurp_utf8 : '';
}

sub log_of {
  my $f = path( $_[0] )->child('.karr.log');
  return $f->exists ? $f->slurp_utf8 : '';
}

sub coordinator_env {
  my $f = $OUT->child('env');
  return '' unless $f->exists;
  return $f->slurp_utf8;
}

# ---------------------------------------------------------------------------
# 1. Which agent is the coordinator
# ---------------------------------------------------------------------------

subtest 'the coordinator is a marked agent definition, not a second config key'
=> sub {
  my $cfg = write_config(
    agents => {
      worker  => { command => 'true' },
      planner => { command => 'true', kind => 'claude-code',
                   role => 'coordinator' },
    },
  );
  my $c = coordinator($cfg);
  is $c->name, 'planner', 'the definition marked role: coordinator is the one';
  ok $c->configured, 'and the fleet has a judgement layer';

  my $none = coordinator( write_config( agents => { w => { command => 'true' } } ) );
  is $none->name, undef, 'a fleet that marks none has none';
  ok !$none->configured, 'and says so';

  my $two = coordinator( write_config( agents => {
    a => { command => 'true', role => 'coordinator' },
    b => { command => 'true', role => 'coordinator' },
  } ) );
  my $err = do { local $@; eval { $two->name }; $@ };
  like $err, qr/both marked/,
    'two marked definitions are refused rather than guessed between: "which '
    . 'of these is the judgement layer" has no safe default';

  my $typo = coordinator( write_config( agents => {
    a => { command => 'true', role => 'coordinater' },
  } ) );
  my $terr = do { local $@; eval { $typo->name }; $@ };
  like $terr, qr/unknown role 'coordinater'/,
    'and a typo in the marker is a hard error, not a fleet that quietly has '
    . 'no judgement layer at all';
};

# ---------------------------------------------------------------------------
# 2. The hot path: a lookup, and no AI in it
# ---------------------------------------------------------------------------

subtest 'the assignment routes a board, and the first working agent wins' => sub {
  fake_out();
  my $repo = make_repo();

t/210-foundation-coordinator.t  view on Meta::CPAN

  is( ( $f->_resolve_agent( $other, {} ) )[0], 'default-cmd',
    'and a repository the assignment does not name falls through to the '
    . 'fleet default exactly as it did before there was an assignment' );
};

subtest 'an assignment naming an agent this machine has not is not fatal' => sub {
  my $repo = make_repo();
  my $cfg  = write_config( agents => {
    here    => { command => 'here-cmd' },
    planner => { command => 'true', role => 'coordinator' },
  } );
  write_assignment( $cfg,
    { repos => { "$repo" => [ 'elsewhere', 'here' ] } } );

  my $f = foundation($cfg);
  is( ( $f->_resolve_agent( $repo, {} ) )[0], 'here-cmd',
    'an agent this machine does not define is skipped, not refused: agent '
    . 'definitions are local and only local, so a table written where more of '
    . 'them exist is a normal thing to meet' );
  is_deeply [ @{ $f->_coordinator->wanted } ], [],
    'and that is not a deviation either';

  write_assignment( $cfg, { repos => { "$repo" => ['elsewhere'] } } );
  my $f2 = foundation($cfg);
  is( ( $f2->_resolve_agent( $repo, {} ) )[0], undef, 'a chain of nothing but '
    . 'unknown names routes nothing' );
  is scalar @{ $f2->_coordinator->wanted }, 1,
    'and that IS a deviation the coordination agent hears about';
};

# ---------------------------------------------------------------------------
# 3. One call per tick, at the end of it
# ---------------------------------------------------------------------------

subtest 'a tick with no assignment calls the coordination agent once' => sub {
  my $out  = fake_out();
  my $hub  = make_repo();
  my @repo = ( make_repo(), make_repo(), make_repo() );
  seed_board( $_, { status => 'todo' } ) for @repo;

  my $cfg = write_config(
    hub     => "$hub",
    dirs    => [ map { "$_" } @repo ],
    routing => "minimax is cheap and does the routine work.\n"
             . "Never hand it a release.",
    agents  => {
      minimax => { command => 'minimax-cmd', description => 'cheap and fast' },
      planner => { command => write_coordinator($hub), kind => 'claude-code',
                   role => 'coordinator',
                   description => 'the one that thinks' },
    },
  );

  my ( $printed ) = capture( sub { foundation($cfg)->run } );

  is scalar( coordinator_runs() ), 1,
    'THREE boards nobody has routed are ONE call: a tick that met five '
    . 'deviations has learned one thing, and five calls would pay five times '
    . 'to hear it';

  my $prompt = coordinator_prompt();
  like $prompt, qr/\Q$_\E: no assignment names this repository/, "prompt names $_"
    for @repo;
  like $prompt, qr/Never hand it a release/,
    'the operator\'s own prose reaches it -- that prose IS the routing '
    . 'criterion, and karr never parses it';
  like $prompt, qr/cheap and fast/, 'so does each agent\'s description';
  like $prompt, qr/\Qminimax\E\s+kind: shell\s+ok/, 'with what is known about it now';
  like $prompt, qr/assignment\s+\Q@{[ path($cfg)->sibling('assignment.yml') ]}\E/,
    'and the path it is supposed to write';
  like $prompt, qr/never names an agent|Name an agent in a chain step/i,
    'the boundary that keeps routing out of the shared chain is stated';

  my $env = coordinator_env();
  like $env, qr/role=coordinator/,
    'it runs under its own role, so its karr writes are not an agent\'s '
    . 'engagement with a card';
  like $env, qr/task=$/m, 'and it is given no ticket: it is not working a card';
  like $env, qr{cwd=\Q@{[ path($hub)->realpath ]}\E},
    'in the hub, where the chain and the questions it may write live';

  like $printed, qr/calling the coordination agent 'planner' for 3 deviation/,
    'and the tick says it out loud';

  my $log = log_of($hub);
  like $log, qr/START role=coordinator agent=planner/,
    'the run is in the hub\'s log like every other run karr starts';
  like $log, qr/COORDINATION wanted:/, 'together with what it was called for';
};

subtest 'the chain\'s three deviations are one call, after the tick' => sub {
  my $out    = fake_out();
  my $hub    = make_repo();
  my $repo   = make_repo();
  my $marker = path($repo)->child('marker');
  seed_board( $repo, { status => 'done' } );     # nothing actionable left

  my $cfg = write_config(
    hub    => "$hub",
    agents => { planner => { command => write_coordinator($hub),
                             kind => 'claude-code', role => 'coordinator' } },
  );

  chain_store($hub)->write_chain( [
    { id => 1, kind => 'plan', note => 'what next?' },
    { id => 2, kind => 'shell', repo => "$repo", command => "echo x >> '$marker'",
      precheck => 'board_actionable == yes' },
    { id => 3, kind => 'plan', note => 'and then?' },
  ] );

  my ( $printed, $exit ) = capture( sub { foundation($cfg)->run('chain') } );
  is $exit, 0, 'the tick finished';
  ok !$marker->exists, 'the stale step did not run';

  is scalar( coordinator_runs() ), 1,
    'two plan steps and one stale step are ONE call at the end of the tick';
  my $prompt = coordinator_prompt();
  like $prompt, qr/step 1: kind: plan is not executed here/, 'the plan step is named';
  like $prompt, qr/step 3: kind: plan is not executed here/, 'both of them';
  like $prompt, qr/step 2: .*precheck/,
    'and the stale step, with the precheck that stopped holding';
  like $printed, qr/the coordination agent is called at the end of this tick/,
    'the tick says a planner is wanted AND that one exists to be called';
};

subtest 'an overdue escalate_to_ai question is one of the deviations' => sub {
  my $out = fake_out();
  my $hub = make_repo();
  my $cfg = write_config(
    hub    => "$hub",
    agents => { planner => { command => write_coordinator($hub),
                             kind => 'claude-code', role => 'coordinator' } },
  );

  chain_store($hub)->write_chain( [ { id => 1, kind => 'question' } ] );
  my $qid = App::karr::Foundation::Questions->new(
    git => App::karr::Git->new( dir => "$hub" ) )->ask(
      question => 'which registry?', policy => 'escalate_to_ai',
      deadline => '2000-01-01T00:00:00Z', step => 1 );

  my ( $printed ) = capture( sub { foundation($cfg)->run('chain') } );

  is scalar( coordinator_runs() ), 1, 'the policy that names the agent calls it';
  like coordinator_prompt(), qr/step 1: escalate_to_ai on question #\Q$qid\E/,
    'naming the question, not merely the step';
  is chain_store($hub)->step(1)->{state}, 'pending',
    'and the step is left exactly as the planner left it: the question is '
    . 'still open, and nothing here answered it on the agent\'s behalf';
};

# ---------------------------------------------------------------------------
# 4. An agent like any other
# ---------------------------------------------------------------------------

subtest 'a coordination agent that fails is marked failing and then waited for'
=> sub {
  my $out  = fake_out();
  my $hub  = make_repo();
  my $repo = make_repo();
  seed_board( $repo, { status => 'todo' } );
  my $cfg = write_config(
    hub    => "$hub",
    dirs   => [ "$repo" ],
    agents => { planner => { command => write_coordinator($hub),
                             kind => 'claude-code', role => 'coordinator',
                             probe_every => '30m' } },
  );

  {
    local $ENV{FAKE_EXIT} = 3;
    my ( $printed ) = capture( sub { foundation($cfg)->run } );
    like $printed, qr/coordination agent 'planner' failed: exit=3/,
      'a bad exit is a failure like any other agent\'s';
  }
  my $state = agent_record( $cfg, 'planner' );
  is $state->{state}, 'failing',
    'and it goes into the same availability record every board agent uses';
  is $state->{last_error}, 'exit=3', 'with what was seen';
  cmp_ok $state->{next_attempt} // 0, '>', time + 1500,
    'and its own probe_every decides when it is tried again';

  # The second tick: the same deviation, an agent that is failing. The place
  # that wanted it waits -- which is what karr-foundation did before there was
  # a coordination agent at all.
  my ( $again ) = capture( sub { foundation($cfg)->run } );
  is scalar( coordinator_runs() ), 1, 'it is not called again while it fails';
  like $again, qr/the coordination agent 'planner' is failing/,
    'and the tick says why nothing was planned';
  like $again, qr/the plan waits/, 'the deviation simply keeps waiting';
};

subtest 'the run is classified from its result JSON, never from its transcript'
=> sub {
  my $out  = fake_out();
  my $hub  = make_repo();
  my $repo = make_repo();
  seed_board( $repo, { status => 'todo' } );
  my $cfg = write_config(
    hub    => "$hub",
    dirs   => [ "$repo" ],
    agents => { planner => { command => write_coordinator($hub),
                             kind => 'claude-code', role => 'coordinator' } },
  );