view release on metacpan or  search on metacpan

t/193-foundation-on-drained.t  view on Meta::CPAN

  $file->spew_utf8( YAML::XS::Dump( \%data ) );
  return $file;
}

sub state_data {
  my ( $repo ) = @_;
  my $file = path( $repo )->child('.karr.state');
  return $file->exists ? json_decode( $file->slurp_utf8 ) : {};
}

sub log_of {
  my ( $repo ) = @_;
  my $file = path( $repo )->child('.karr.log');
  return $file->exists ? $file->slurp_utf8 : '';
}

# The agent: finishes every actionable card it finds, one per run, and leaves
# an activity-log entry behind so foundation can see it engaged the board.
sub write_fake_agent {
  my ( $dir ) = @_;
  my $lib    = path('lib')->absolute->stringify;
  my $script = path($dir)->child('fake-agent.pl');
  $script->spew_utf8(<<'PERL');
use strict;
use warnings;
require App::karr::Git;
require App::karr::BoardStore;
require App::karr::ActivityLog;
my $repo = $ENV{KARR_REPO} or die "no KARR_REPO\n";
open my $fh, '>>', "$repo/agent-runs.log" or die $!;
print {$fh} "run\n";
close $fh;
my $store = App::karr::BoardStore->new(
  git => App::karr::Git->new( dir => $repo ) );
my ( $t ) = grep {
  $_ && !$_->has_blocked && $_->status ne 'done' && $_->status ne 'archived'
} $store->load_tasks;
exit 0 unless $t;
$t->status('done');
$store->save_task($t);
App::karr::ActivityLog->new( git => $store->git, role => 'agent' )->log_entry(
  agent => 'fake-agent', action => 'move', task_id => $t->id + 0, detail => 'done' );
PERL
  return qq{$^X -I"$lib" "$script"};
}

# The hook. It records the environment it was handed -- that is the whole
# contract from karr's side -- and, when told to, puts a card back on the
# board, which is the case the ticket says the hook has to tolerate being the
# cause of.
sub write_fake_hook {
  my ( $dir ) = @_;
  my $lib    = path('lib')->absolute->stringify;
  my $script = path($dir)->child('fake-hook.pl');
  $script->spew_utf8(<<'PERL');
use strict;
use warnings;
use Cwd ();
my $repo = $ENV{KARR_REPO} or die "no KARR_REPO\n";
open my $fh, '>>', "$repo/hook-runs.log" or die $!;
printf {$fh} "role=%s task=[%s] prompt=[%s] cwd=%s\n",
  ( $ENV{KARR_ROLE} // '<unset>' ), ( $ENV{KARR_TASK} // '<unset>' ),
  ( $ENV{PROMPT} // '<unset>' ), Cwd::getcwd();
close $fh;

print $ENV{KARR_FAKE_HOOK_OUTPUT} . "\n" if $ENV{KARR_FAKE_HOOK_OUTPUT};

if ( $ENV{KARR_FAKE_HOOK_FILES} ) {
  require App::karr::Git;
  require App::karr::BoardStore;
  require App::karr::Task;
  my $store = App::karr::BoardStore->new(
    git => App::karr::Git->new( dir => $repo ) );
  my $id = $store->allocate_next_id;
  $store->save_task( App::karr::Task->new(
    id => $id, title => "the gate found something", status => 'todo' ) );
}

exit( $ENV{KARR_FAKE_HOOK_EXIT} // 0 );
PERL
  return qq{$^X -I"$lib" "$script"};
}

# Returned as an array so `scalar hook_runs($repo)` is the count and not the
# undef a bare `return ()` yields in scalar context.
sub runs_in {
  my ( $repo, $file ) = @_;
  my $log = path( $repo )->child( $file );
  my @lines = $log->exists ? ( grep { length } split /\n/, $log->slurp_utf8 ) : ();
  return @lines;
}

sub hook_runs  { return runs_in( $_[0], 'hook-runs.log' ) }
sub agent_runs { return runs_in( $_[0], 'agent-runs.log' ) }

# ---------------------------------------------------------------------------
# Where the command comes from
# ---------------------------------------------------------------------------

subtest 'on_drained is a .karr key with a config-wide fallback' => sub {
  my $f = App::karr::Foundation->new( _config_data => {} );
  is $f->_on_drained_command( {} ), undef,
    'no hook configured anywhere is the default -- nothing runs';

  is $f->_on_drained_command( { on_drained => 'gate.sh' } ), 'gate.sh',
    'the .karr key names it';

  my $g = App::karr::Foundation->new(
    _config_data => { on_drained => 'fleet-gate.sh' } );
  is $g->_on_drained_command( {} ), 'fleet-gate.sh',
    'a fleet can configure one for every board it drains';
  is $g->_on_drained_command( { on_drained => 'own.sh' } ), 'own.sh',
    'and the board is the more specific statement, as everywhere else here';
  is $g->_on_drained_command( { on_drained => '' } ), undef,
    'an empty string turns the fleet-wide hook off for one board';
};

# ---------------------------------------------------------------------------
# When it runs
# ---------------------------------------------------------------------------

t/193-foundation-on-drained.t  view on Meta::CPAN

  path( $repo )->child('.karr')->spew_utf8(
    "command: true\nmax_runtime: 60\non_drained: $hook\n" );

  my $f = App::karr::Foundation->new( _config_data => {}, force => 1 );
  $f->_process_repo( path( $repo ) );

  is scalar hook_runs( $repo ), 0,
    'an idle run over a board that still has cards is not a drained board';
};

subtest 'blocked and finished cards are not work, so the board has drained' => sub {
  my $repo = make_git_repo();
  my $hook = write_fake_hook( $repo );
  my $store = seed_board( $repo, 'cannot be done', 'already done' );
  my $blocked = $store->find_task( 1 );
  $blocked->block( 'waiting for the other repo' );
  $store->save_task( $blocked );
  my $done = $store->find_task( 2 );
  $done->status( 'done' );
  $store->save_task( $done );

  my $f = App::karr::Foundation->new( _config_data => {}, force => 1 );
  $f->_process_repo( path( $repo ) );
  # No agent is configured, so nothing is drained and nothing is hooked.
  is scalar hook_runs( $repo ), 0, 'no agent, no drain, no hook';

  my $agent = write_fake_agent( $repo );
  path( $repo )->child('.karr')->spew_utf8(
    "command: $agent\nmax_runtime: 60\non_drained: $hook\n" );
  $f->_process_repo( path( $repo ) );
  is scalar hook_runs( $repo ), 1,
    'a board whose remainder is blocked or terminal has no actionable work '
    . 'left, which is what draining means';
};

subtest 'a run that broke says nothing about the board being finished' => sub {
  my $repo = make_git_repo();
  my $hook = write_fake_hook( $repo );
  path( $repo )->child('.karr')->spew_utf8(
    "command: exit 3\nmax_runtime: 60\non_drained: $hook\n" );

  my $f = App::karr::Foundation->new( _config_data => {}, force => 1 );
  $f->_process_repo( path( $repo ) );

  ok $f->_cooldown_active( path( $repo ) ), 'the board is in cooldown';
  is scalar hook_runs( $repo ), 0,
    'an agent that could not run leaves an empty-looking board that is not '
    . 'evidence of anything -- the hook is not called on it';
};

# ---------------------------------------------------------------------------
# What the hook is told
# ---------------------------------------------------------------------------

subtest 'the hook is told where it is and nothing else' => sub {
  my $repo  = make_git_repo();
  seed_board( $repo, 'tidy the parser' );
  my $agent = write_fake_agent( $repo );
  my $hook  = write_fake_hook( $repo );
  path( $repo )->child('.karr')->spew_utf8(
    "command: $agent\nmax_runtime: 60\nprompt: DO THE AGENT THING\n"
    . "on_drained: $hook\n" );

  my $f = App::karr::Foundation->new( _config_data => {} );
  $f->_process_repo( path( $repo ) );

  my ( $line ) = hook_runs( $repo );
  ok defined $line, 'the hook ran' or return;
  like $line, qr/\brole=hook\b/,
    'KARR_ROLE says hook, so a karr write of its own is not filed as the '
    . "agent's engagement with a card";
  like $line, qr/\btask=\[\]/, 'no ticket: the hook was given no assignment';
  like $line, qr/\bprompt=\[\]/,
    'and no prompt -- the prompt is the agent instruction, and the hook is '
    . 'not an agent';
  like $line, qr{\bcwd=\Q$repo\E}, 'it runs in the board it drained';
};

# ---------------------------------------------------------------------------
# What the hook is not
# ---------------------------------------------------------------------------

subtest 'a hook that fails is not a failing agent' => sub {
  my $repo   = make_git_repo();
  seed_board( $repo, 'tidy the parser' );
  my $agent  = write_fake_agent( $repo );
  my $hook   = write_fake_hook( $repo );
  my $cfg    = write_config( agents => { fake => { command => $agent } } );
  path( $repo )->child('.karr')->spew_utf8(
    "agent: fake\nmax_runtime: 60\non_drained: $hook\n" );

  local $ENV{KARR_FAKE_HOOK_EXIT}   = 4;
  # The exact text the run classifier backs a board off for. A hook is not
  # classified at all, so it must not matter what it printed.
  local $ENV{KARR_FAKE_HOOK_OUTPUT} = 'API Error: 429 Too Many Requests';

  my $f = App::karr::Foundation->new( config => "$cfg" );
  $f->_process_repo( path( $repo ) );

  is scalar hook_runs( $repo ), 1, 'the hook ran and failed';
  my $state = state_data( $repo );
  ok !$f->_cooldown_active( path( $repo ) ),
    'a failed hook does not park the board';
  ok !exists $state->{last_error}, 'and is not recorded as the run\'s error';
  is $state->{last_exit}, 0, 'last_exit still describes the agent run';
  ok $f->_agents->available( 'fake' ),
    'nor does it mark the agent that drained the board as failing (#188)';
  like log_of( $repo ), qr/ON-DRAINED exit=4/,
    'what it did is written down, and interpreted by nobody';
  is $state->{last_on_drained}{exit}, 4, 'and kept for the operator';
};

# ---------------------------------------------------------------------------
# The loop question
# ---------------------------------------------------------------------------

subtest 'the hook does not run twice on the same board' => sub {
  my $repo = make_git_repo();
  my $hook = write_fake_hook( $repo );
  my $karr = { on_drained => $hook, max_runtime => 60 };

  my $f = App::karr::Foundation->new( _config_data => {} );
  $f->_run_on_drained( path( $repo ), $karr, { outcome => 'progress' } );
  is scalar hook_runs( $repo ), 1, 'the drained board called it';

  $f->_run_on_drained( path( $repo ), $karr, { outcome => 'progress' } );
  $f->_run_on_drained( path( $repo ), $karr, { outcome => 'idle' } );
  is scalar hook_runs( $repo ), 1,
    'a board that has not moved since is the same board, and the hook has '
    . 'already had its say about it -- otherwise a quiet repo would run a '
    . 'release gate on every cron tick, for ever';

  seed_board( $repo, 'something new happened' );
  my $store = store_of( $repo );