App-karr
view release on metacpan or search on metacpan
lib/App/karr/Foundation/ChainStore.pm view on Meta::CPAN
my $base = $self->_run_base($run);
$self->prune_logs if $self->auto_prune && !$self->git->ref_exists($base);
$entry{ts} //= _now();
my $line = json_encode( \%entry );
return try {
$self->git->retry_contended( "run log $run", sub {
my @segments = $self->_run_segments($run);
my $segment = @segments ? $segments[-1] : $base;
my ( $oid, $content ) = @segments
? $self->git->read_ref_with_oid($segment) : ( undef, '' );
$content //= '';
# Rotate before the append, never after: no segment is written past the
# cap, no entry is written twice, and a full segment is left alone from
# then on. The next segment is opened with expected_old => undef, so two
# writers rotating at once cannot clobber one another -- the loser
# re-reads and appends to the segment the winner opened.
if ( length($content)
&& length($content) + 1 + length($line) > $self->segment_max_bytes )
{
my ( $index ) = $segment =~ /\+([0-9]+)\z/;
$segment = sprintf( '%s+%06d', $base, ( $index // 0 ) + 1 );
( $oid, $content ) = ( undef, '' );
}
my $new = length $content ? "$content\n$line" : $line;
return $self->git->write_ref_cas( $segment, $new, $oid ) ? 1 : ();
} );
} catch {
warn "karr-foundation: run log write to '$base' failed: " . clean_error($_) . "\n";
0;
};
}
sub run_ids {
my ( $self ) = @_;
my %run;
for my $ref ( $self->git->list_refs(LOG_ROOT) ) {
my $name = substr $ref, length LOG_ROOT;
$name =~ s/\+[0-9]+\z//;
$run{$name} = 1 if _valid_run($name);
}
my @runs = sort keys %run;
return @runs;
}
sub run_entries {
my ( $self, $run ) = @_;
return () unless _valid_run($run);
my @entries;
for my $ref ( $self->_run_segments($run) ) {
my $content = $self->git->read_ref($ref);
next unless defined $content && length $content;
for my $line ( split /\n/, $content ) {
next unless length $line;
my $decoded = try { json_decode($line) } catch { undef };
push @entries, $decoded if $decoded;
}
}
return @entries;
}
sub prune_logs {
my ( $self, %opt ) = @_;
my $keep_days = defined $opt{keep_days} ? $opt{keep_days} : $self->keep_days;
my $keep_runs = defined $opt{keep_runs} ? $opt{keep_runs} : $self->keep_runs;
my @runs = $self->run_ids;
my %doomed;
if ( $keep_days ) {
my $cutoff = strftime( '%Y-%m-%d', gmtime( time - $keep_days * 86400 ) );
$doomed{$_} = 1 for grep { substr( $_, 0, 10 ) lt $cutoff } @runs;
}
if ( $keep_runs && @runs > $keep_runs ) {
$doomed{$_} = 1 for @runs[ 0 .. $#runs - $keep_runs ];
}
my @gone;
for my $run ( sort keys %doomed ) {
$self->git->delete_ref($_) for $self->_run_segments($run);
push @gone, $run;
}
return @gone;
}
# ---------------------------------------------------------------------------
# Reading refs
# ---------------------------------------------------------------------------
sub _read_yaml {
my ( $self, $ref, $what ) = @_;
my $content = $self->git->read_ref($ref);
return undef unless defined $content && length $content;
return $self->_decode_yaml( $content, $what );
}
# A ref that does not parse is skipped with a warning rather than dying: one
# hand-edited step must not make the whole chain unreadable, and the runner's
# answer to a step it cannot see is to leave it alone.
sub _decode_yaml {
my ( $self, $content, $what ) = @_;
my $data = try { yaml_load($content) } catch {
warn "karr-foundation: cannot read $what: " . clean_error($_) . "\n";
undef;
};
return ref $data eq 'HASH' ? $data : undef;
}
1;
__END__
=pod
=encoding UTF-8
lib/App/karr/Foundation/ChainStore.pm view on Meta::CPAN
history -- quadratic, and measured at about 4.6 GB of objects for a 1 MB log
(#171, L<App::karr::ActivityLog/Segments>). The C<+NNNNNN> spelling is
deliberately the same one the activity log uses; this store keeps its own copy
of the mechanism rather than sharing one, because the activity log's version is
tangled up with identity encoding and pre-#75 ref names that have no meaning
here.
Retention is the other half of that bound: L</prune_logs> drops runs older than
L</keep_days> and, whatever their age, everything past the newest L</keep_runs>.
It runs by itself when a run log is opened (L</auto_prune>), because a retention
policy that only runs when somebody types a command bounds nothing.
=head1 SEE ALSO
L<App::karr::Foundation>, L<App::karr::Foundation::Agents>,
L<App::karr::ActivityLog>, L<App::karr::Git>
=head2 git
The L<App::karr::Git> for the hub repository that carries the fleet namespace.
Required.
=head2 write_chain
my $chain_id = $store->write_chain( \@steps, %opt );
Replaces the chain with C<@steps> and returns the new chain id. Options are
C<limits> (passed through to the header untouched -- what a limit means is the
runner's business), C<note>, C<planner>, and C<force>.
Every step is validated first (L</validate_chain>): anything wrong with the
chain raises a user error and B<nothing is written>.
The header ref is written B<last> and is the commit point: L</ready_steps> only
considers steps whose C<chain> matches the header, so a reader that arrives
half-way through a replacement sees the chain it saw before, then the new one,
and never a mixture. Both C<meta> and the step refs are separate refs, so this
is not a git-level atomic switch -- the window is one where nothing is ready,
not one where the wrong thing runs.
=head2 validate_chain
my $steps = $store->validate_chain( \@steps, %opt );
Everything L</write_chain> checks before it writes a ref, and no ref written:
every step against the step schema, ids unique, every C<needs> entry naming a
step of the same chain, the graph acyclic, and -- unless C<force> is passed --
no step of the chain still in state C<running>. Returns the validated steps,
which are normalised copies rather than the caller's own hashes; anything else
raises a user error.
Split out of L</write_chain> because C<karr-foundation plan --dry-run> has to
be able to say "this chain is good" without writing it, and a dry run checking
a chain from its own copy of the rules would be a second opinion rather than
the same one.
=head2 parse_chain_document
my ( $steps, %header ) = $store->parse_chain_document( $document );
Takes the decoded document C<karr-foundation plan> reads -- YAML or JSON, and
JSON only because a YAML parser reads it -- and returns the two arguments
L</write_chain> takes: the step list, and the header options C<limits>, C<note>
and C<planner>.
Two spellings are accepted, because both say the same thing: a mapping with a
C<steps:> list and the header keys beside it, or a bare list, which B<is> the
step list. The second is what L</write_chain>'s own first argument looks like,
so a planner writing only steps has written a whole document.
No step is looked at here -- that is L</validate_chain>, which the write path
runs whatever route the steps arrived by. What this checks is the envelope:
the document is one of the two shapes, C<steps:> is there and is a list,
C<limits:> is a mapping, C<note:> and C<planner:> are plain values, and no
other key is present. C<force> is deliberately not among them: replacing a
chain that still has a running step is a decision the caller makes on the
command line, not one the plan grants itself.
=head2 header
my $header = $store->header; # { id => ..., created => ..., limits => ... }
The chain header, or C<{}> when no chain is written. C<limits> comes back
exactly as it was handed in.
=head2 steps
my @steps = $store->steps;
Every step ref that exists, oldest chain generation included, sorted by id
(numeric ids numerically, before named ones). Deliberately unfiltered so a
half-written or superseded chain can still be looked at; L</ready_steps> is
where the header decides what may actually run.
=head2 step
my $step = $store->step($id);
One step, or C<undef> when there is no such ref.
=head2 update_step
my $new = $store->update_step( $id, sub {
my ($step) = @_;
return undef unless ( $step->{state} // 'pending' ) eq 'pending';
$step->{state} = 'running';
return $step;
} );
Read-modify-write on one step, compare-and-swap guarded. The callback receives
the step as it is on the ref and returns the step to write, or C<undef> to
decline. Returns the written step, or C<undef> when the step does not exist or
the callback declined.
The guard is what makes this usable from more than one foundation tick: two
callers that both read C<pending> do not both write C<running>: the loser's
write is refused, the callback is called again with what the winner left
behind, and it declines. That is the whole exclusion mechanism for a
concurrent runner, and it is the board's own (L<App::karr::Git/retry_contended>,
L<App::karr::Git/write_ref_cas>) rather than a second one.
lib/App/karr/Foundation/ChainStore.pm view on Meta::CPAN
How large a run-log segment may grow before the next entry opens the following
one; 8192 by default, the same cap and the same reason as
L<App::karr::ActivityLog/segment_max_bytes>. Set explicitly only by tests,
which have to see a rotation without writing thousands of entries.
=head2 keep_days
How many days of run logs L</prune_logs> keeps; 14 by default. C<0> means no
age limit, the same spelling C<max_turns> and C<max_runtime> use for "no limit".
=head2 keep_runs
How many run logs L</prune_logs> keeps regardless of age, newest first; 500 by
default, C<0> for no ceiling. This is the one that actually bounds the
namespace: a fleet busy enough to matter fills two weeks with more refs than
anyone wants to fetch.
=head2 auto_prune
Whether opening a new run log prunes the old ones first; true by default. Once
per run is cheap (one ref listing) and it is the only moment at which the
namespace grows, so retention that hangs off it cannot be forgotten.
=head2 new_run_id
my $run = $store->new_run_id; # "2026-08-17-142530a3f91c"
Mints a run name: the UTC date, then the UTC time and six random hex digits.
The date leads so the refs sort chronologically, which is what makes retention
a matter of looking at the front of a sorted list.
=head2 log_run
$store->log_run( $run, event => 'step', step => 3, detail => 'done' );
Appends one JSON entry to a run's log, timestamping it unless C<ts> is given.
Returns 1 when the entry landed and 0 after a warning when it could not: a run
log records what already happened, so failing to write it must not take the run
down with it -- the same rule L<App::karr::ActivityLog/log_entry> follows. A
C<$run> that is not a run name is the exception, and raises: that is a caller
mistake, not a write that failed.
The append is compare-and-swap guarded against the newest segment, re-resolved
on every attempt, so two writers cannot lose each other's entries and a rotation
is just another lost race. Opening a run (the first entry) prunes old runs first
when L</auto_prune> is set.
=head2 run_ids
my @runs = $store->run_ids;
Every run that has a log, oldest first -- which is plain lexical order, because
the name starts with the date. Segments are folded back into the run they
belong to.
=head2 run_entries
my @entries = $store->run_entries($run);
The decoded entries of one run, oldest first, read across every segment.
=head2 prune_logs
my @gone = $store->prune_logs; # the configured policy
my @gone = $store->prune_logs( keep_days => 2 ); # or an explicit one
Drops the run logs the retention policy no longer keeps -- everything older
than L</keep_days>, plus everything past the newest L</keep_runs> -- and
returns the run names it removed. Every segment of a removed run goes.
Deleting these refs leaves no tombstone: L<App::karr::Git/delete_ref> only
records those for C<refs/karr/*>, so a pruned run is gone locally and stays on
the remote until the sync of this namespace (#190) says otherwise.
=head1 SUPPORT
=head2 Issues
Please report bugs and feature requests on GitHub at
L<https://github.com/Getty/karr/issues>.
=head2 IRC
Join C<#langertha> on C<irc.perl.org> or message Getty directly.
=head1 CONTRIBUTING
Contributions are welcome! Please fork the repository and submit a pull request.
=head1 AUTHOR
Torsten Raudssus <getty@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2026 by Torsten Raudssus <torsten@raudssus.de> L<https://raudssus.de/>.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut
( run in 1.252 second using v1.01-cache-2.11-cpan-364913b4093 )