view release on metacpan or  search on metacpan

t/213-foundation-plan-cli.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More;
use lib 't/lib';
use TestGit qw( require_git_c );
require_git_c();
use File::Temp qw( tempdir );
use Path::Tiny qw( path );
use Cwd qw( abs_path getcwd );
use IPC::Open3 qw( open3 );
use Symbol qw( gensym );
use Encode qw( encode );

use App::karr::Git;
use App::karr::Encoding qw( yaml_load );
use App::karr::Foundation;
use App::karr::Foundation::ChainStore;

# Ticket #213: karr-foundation gets a command that writes a chain.
#
# Before it, App::karr::Foundation::ChainStore->write_chain was the only way in
# -- Perl API -- so the one writer that is not a person, the coordination
# agent (#210), was handed a `perl -MApp::karr::Foundation::ChainStore -e ...`
# one-liner in its prompt and asked to type it out. That was the single place
# where karr gave an agent Perl instead of a command, and it meant a rename
# inside that class broke a prompt rather than a call: silently, and only on
# the tick where a plan was wanted.
#
# What is pinned here, and why each is a decision rather than an accident:
#
#   1. The chain arrives as a DOCUMENT on stdin (or --input), not as options.
#      A chain is a DAG and a DAG is nested; the writer that matters most
#      already produces structure. YAML, and JSON through the same parser.
#   2. It REPLACES the chain, it does not append. Only steps whose chain id
#      matches the header are ever ready, so an append would be a new chain
#      over the old steps and the new ones -- a merge with rules of its own.
#   3. Validation is the store's, and nothing is written when it fails: a
#      document karr will not take leaves the chain in the hub exactly as it
#      was, and the writer gets a sentence rather than a Perl error.
#   4. The exit-code contract holds (ADR 0002): a bad invocation is 2, a bad
#      document is 1 -- the document is data, not argv.
#   5. The coordination agent's prompt names the command and no longer carries
#      Perl for it to type.
#
# No agent is ever started: the only invocations here write or check a chain,
# and the prompt is built in-process without dispatching it.

my $ROOT = abs_path('.');

sub run_foundation {
    my ( %arg ) = @_;
    my $old = getcwd();
    my $cwd = $arg{cwd} // $ROOT;
    chdir $cwd or die "chdir $cwd: $!";
    my $errfh = gensym;
    my $pid = open3( my $in, my $outfh, $errfh,
        $^X, "-I$ROOT/lib", "$ROOT/bin/karr-foundation", @{ $arg{argv} } );
    if ( defined $arg{stdin} ) {
        binmode $in, ':raw';
        print {$in} encode( 'UTF-8', $arg{stdin} );
    }
    close $in;
    my $out = do { local $/; <$outfh> };
    my $err = do { local $/; <$errfh> };
    waitpid( $pid, 0 );
    my $exit = $? >> 8;
    chdir $old or die "chdir back: $!";
    return {
        exit   => $exit,
        stdout => defined $out ? $out : '',
        stderr => defined $err ? $err : '',
    };
}

sub init_repo {
    my $repo = tempdir( CLEANUP => 1 );
    system( 'git', 'init', '-q', $repo ) == 0 or BAIL_OUT('git init failed');
    system( 'git', '-C', $repo, 'config', 'user.email', 'fleet@example.com' ) == 0
        or BAIL_OUT('git config failed');
    system( 'git', '-C', $repo, 'config', 'user.name', 'Fleet' ) == 0
        or BAIL_OUT('git config failed');
    return $repo;
}

# A config in a directory of its own, so agents.state and assignment.yml never
# land next to somebody's real fleet.
sub write_config {
    my ( $body ) = @_;
    my $cfg = path( tempdir( CLEANUP => 1 ) )->child('config.yml');
    $cfg->spew_utf8($body);
    return "$cfg";
}

sub store {
    my ( $repo ) = @_;
    return App::karr::Foundation::ChainStore->new(
        git => App::karr::Git->new( dir => "$repo" ) );
}

sub step_refs {
    my ( $repo ) = @_;
    my @refs = sort( split /\n/,
        `git -C '$repo' for-each-ref --format='%(refname)' 'refs/karr-foundation/chain/'` );
    return \@refs;
}

t/213-foundation-plan-cli.t  view on Meta::CPAN

        argv => [ '--config', $cfg, 'plan', 'chain.yml' ], stdin => $FOUR_STEPS );
    is( $surplus->{exit}, 2, 'a surplus positional is a usage error' );
    like( $surplus->{stderr}, qr/\AUsage: karr-foundation plan/,
        'on the marker bin/karr-foundation keys the split on' );

    my $bogus = run_foundation( cwd => $hub,
        argv => [ '--config', $cfg, 'plan', '--totally-bogus' ] );
    is( $bogus->{exit}, 2, 'an unknown option is one too' );

    # 1: the invocation was right, what arrived was not.
    my $empty = run_foundation( cwd => $hub, argv => [ '--config', $cfg, 'plan' ] );
    is( $empty->{exit}, 1, 'an empty stdin is a runtime failure' );
    like( $empty->{stderr}, qr/No chain document received on stdin/,
        'and says the pipe was empty' );

    my $nohub = run_foundation( cwd => $hub,
        argv  => [ '--config', write_config("dirs:\n  - $hub\n") , 'plan' ],
        stdin => $FOUR_STEPS );
    is( $nohub->{exit}, 1, 'a fleet with no hub cannot be planned for' );
    like( $nohub->{stderr}, qr/No usable hub repository/,
        'and is told where a hub is named' );

    is( scalar( store($hub)->steps ), 0, 'none of that wrote a chain' );
};

subtest 'the document crosses the octet boundary exactly once' => sub {
    my ( $hub, $cfg ) = fleet();
    my $note = "Gr\x{f6}\x{df}e \x{2014} \x{4e2d}\x{6587}";

    my $r = run_foundation( cwd => $hub, argv => [ '--config', $cfg, 'plan' ],
        stdin => "steps:\n  - id: a\n    kind: shell\n    repo: /srv/x\n"
               . "    command: echo \x{2764}\n"
               . "note: $note\n" );
    is( $r->{exit}, 0, 'a document with non-ASCII in it is accepted' )
        or diag "stderr: $r->{stderr}";

    is( store($hub)->header->{note}, $note,
        'and the note comes back as the characters that went in' );
    my ( $step ) = store($hub)->steps;
    is( $step->{command}, "echo \x{2764}", 'so does a step field' );
};

# ------------------------------------------------- what the planner is told

subtest 'the coordination agent is given the command, not Perl to type' => sub {
    my ( $hub, $cfg ) = fleet();
    path($cfg)->spew_utf8( <<"CONFIG" );
hub: $hub
dirs:
  - $hub
agents:
  planner:
    command: /bin/true
    role: coordinator
CONFIG

    my $foundation = App::karr::Foundation->new( config => $cfg );
    my $coordinator = $foundation->_coordinator;
    ok( $coordinator->configured, 'the fleet marks a coordination agent' );
    $coordinator->want( step => 4, reason => 'kind: plan is not executed here' );
    my $prompt = $coordinator->prompt( $coordinator->wanted );

    unlike( $prompt, qr/perl -M/,
        'the prompt no longer carries a perl one-liner (#213)' );
    unlike( $prompt, qr/write_chain/,
        'nor the name of the storage method it called' );
    like( $prompt, qr/karr-foundation --config '\Q$cfg\E' plan <</,
        'it is told the command, with the config the fleet was started with' );
    like( $prompt, qr/karr-foundation --config '\Q$cfg\E' ask /,
        'and the mailbox command carries it for the same reason' );
    like( $prompt, qr/REPLACES the chain/,
        'and that writing one replaces what is there' );

    # The prompt is worth nothing if the shape in it is not one karr takes, so
    # the document the agent is shown is run through the parser it will meet.
    my ( $document ) = $prompt =~ /plan <<'CHAIN'\n(.*?)\n\s*CHAIN\n/s;
    ok( $document, 'the prompt shows a whole document' );
    $document =~ s/^ {5}//mg;
    my ( $steps, %header ) = store($hub)->parse_chain_document(
        yaml_load($document) );
    is( scalar @$steps, 2, 'which parses as a chain document' );
    my $validated = store($hub)->validate_chain($steps);
    is_deeply( [ map { $_->{id} } @$validated ], [ '1', '2' ],
        'and validates as a chain' );
};

done_testing();