view release on metacpan or  search on metacpan

lib/App/karr/Foundation/ChainStore.pm  view on Meta::CPAN

sub _new_chain_id {
  return strftime( '%Y%m%dT%H%M%SZ', gmtime() ) . '-'
    . substr( md5_hex( $$, time, rand ), 0, 6 );
}


sub header {
  my ( $self ) = @_;
  return $self->_read_yaml( CHAIN_META, 'chain header' ) // {};
}


sub steps {
  my ( $self ) = @_;
  my @steps;
  for my $ref ( $self->git->list_refs(STEP_ROOT) ) {
    my $id = substr $ref, length STEP_ROOT;
    next unless _valid_id($id);
    my $step = $self->_read_yaml( $ref, "chain step '$id'" ) or next;
    push @steps, _as_step( $step, $id );
  }
  # Assigned before it is returned: sort() in scalar context is undefined
  # behaviour, and a caller asking how many steps there are is ordinary.
  my @sorted = sort { _id_sort_key( $a->{id} ) cmp _id_sort_key( $b->{id} ) } @steps;
  return @sorted;
}

# What a step ref holds, as the rest of this class expects to see it: the id
# filled in from the ref name it was found under, and needs always a list. A
# ref written by hand may spell a one-element needs as a scalar, and every
# reader here dereferences it -- normalising once on the way in is cheaper than
# guarding at each of them.
sub _as_step {
  my ( $step, $id ) = @_;
  $step->{id} //= "$id";
  my $needs = $step->{needs};
  $step->{needs} = ref $needs eq 'ARRAY' ? $needs
                 : ( defined $needs && length "$needs" ? [ $needs ] : [] );
  return $step;
}

# A total order over ids that are usually numbers and occasionally not: pad
# the numbers so they sort among themselves numerically, and leave names to
# sort after them (digits sort before letters).
sub _id_sort_key {
  my ( $id ) = @_;
  $id = defined $id ? "$id" : '';
  return $id =~ /\A[0-9]+\z/ ? sprintf( '%020d', $id ) : "~$id";
}


sub step {
  my ( $self, $id ) = @_;
  return undef unless _valid_id($id);
  my $step = $self->_read_yaml( $self->_step_ref($id), "chain step '$id'" )
    or return undef;
  return _as_step( $step, $id );
}


sub update_step {
  my ( $self, $id, $code ) = @_;
  return undef unless _valid_id($id);
  my $ref = $self->_step_ref($id);

  # retry_contended reads an empty return as "lost the race, read again"; a
  # one-element (undef) return is a committed answer and comes back as undef.
  return scalar $self->git->retry_contended( "chain step $id", sub {
    my ( $oid, $content ) = $self->git->read_ref_with_oid($ref);
    return undef unless defined $oid;
    my $step = $self->_decode_yaml( $content, "chain step '$id'" ) or return undef;
    $step = _as_step( $step, $id );

    my $updated = $code->($step);
    return undef unless ref $updated eq 'HASH';
    my $valid = $self->_validate_step($updated);
    user_error("Chain step '$id' cannot be renamed to '$valid->{id}'")
      unless $valid->{id} eq "$id";

    return $self->git->write_ref_cas( $ref, yaml_dump($valid), $oid )
      ? $valid : ();
  } );
}


sub mark_stale {
  my ( $self, $id, $reason ) = @_;
  return $self->update_step( $id, sub {
    my ( $step ) = @_;
    return undef if ( $step->{state} // 'pending' ) eq 'stale';
    $step->{state}    = 'stale';
    $step->{stale_at} = _now();
    if ( defined $reason && length $reason ) { $step->{stale_reason} = $reason }
    else                                     { delete $step->{stale_reason} }
    return $step;
  } );
}


sub ready_steps {
  my ( $self ) = @_;
  my $chain = $self->header->{id};
  return () unless defined $chain;

  my @steps = grep { ( $_->{chain} // '' ) eq $chain } $self->steps;
  my %state = map { $_->{id} => ( $_->{state} // 'pending' ) } @steps;
  return grep {
    my $step = $_;
    ( $state{ $step->{id} } eq 'pending' )
      && !grep { ( $state{$_} // '' ) ne 'done' } @{ $step->{needs} || [] };
  } @steps;
}


sub clear_chain {
  my ( $self ) = @_;
  my $removed = $self->git->delete_ref(CHAIN_META) ? 1 : 0;
  return $removed + $self->_clear_steps;
}

sub _clear_steps {