File Coverage

blib/lib/Dist/AutomationPolicy.pm

Criterion	Covered	Total	%
statement	74	77	96.1
branch	20	28	71.4
condition	11	21	52.3
subroutine	17	17	100.0
pod	4	5	80.0
total	126	148	85.1

package Dist::AutomationPolicy;

use v5.24;

use Moo;

use Carp qw( croak );
use File::ShareDir qw( dist_file );
use JSON::MaybeXS;
use JSON::Schema::Validate v0.7.0;
use Path::Tiny qw( path );
use PerlX::Maybe qw( maybe );
use Types::Common qw( ArrayRef Enum InstanceOf PositiveInt NonEmptyStr StrMatch );

use experimental qw( postderef signatures );

use namespace::autoclean;

our $VERSION = 'v0.2.0';

# ABSTRACT: generate and parse distribution automation policies


has version => (
    is       => 'ro',
    isa      => PositiveInt,
    default  => 1,
    required => 1,
);


# Based on Types::Dist DistVersion but the version is optional

# SPDX-SnippetBegin
# SPDX-SnippetCopyrightText: 2019 by Renee Baecker
# SPDX-License-Identifier: The Artistic License 2.0 (GPL Compatible)

my $distname_re    = qr{ ([A-Za-z][A-Za-z0-9]*) ( - [A-Za-z0-9]+ )* }xmns;
my $distversion_re = qr{ v? ( [0-9]+ ( \. [0-9]+ )* ) }xmns;
my $distfq_re      = qr{$distname_re(-$distversion_re)?}n;

# SPDX-SnippetEnd

has distribution => (
    is        => 'ro',
    isa       => StrMatch[ qr{\A$distfq_re\z} ],
    predicate => 1,
);


has description => (
    is        => 'ro',
    isa       => NonEmptyStr,
    predicate => 1,
);


has document => (
    is        => 'ro',
    isa       => NonEmptyStr,
    predicate => 1,
);


has code_generation => (
    is       => 'ro',
    isa      => Enum [qw( toolchain external_sources machine_generated )],
    required => 1,
);


has automated_contributions => (
    is       => 'ro',
    isa      => Enum [qw( none comment issue code_request )],
    required => 1,
);


has automated_actions => (
    is       => 'ro',
    isa      => Enum [qw( none comment issue code_request code_change release )],
    required => 1,
);


has models => (
    is     => 'ro',
    isa    => ArrayRef [NonEmptyStr],
    coerce => sub($val) {
        return $val if ref($val) eq "ARRAY";
        return [$val];
    },
    builder => sub($self) { return [] },
);


has filename => (
    is      => 'lazy',
    isa     => NonEmptyStr,
    default => 'CPAN-META/automation-policy.json',
);

my $json = JSON::MaybeXS->new( utf8 => 1, pretty => 1, canonical => 1 );

my $file = path( dist_file( __PACKAGE__ =~ s/::/-/gr, "automation-policy-schema.json" ) );

my $schema = JSON::Schema::Validate->new( $json->decode( $file->slurp_raw ), compile => 1, );


sub data($self) {
    #<<<
    return {
        version                 => $self->version,
        maybe distribution      => $self->distribution,
        maybe description       => $self->has_description ? $self->description : undef,
        maybe document          => $self->has_document    ? $self->document    : undef,
        code_generation         => $self->code_generation,
        automated_contributions => $self->automated_contributions,
        automated_actions       => $self->automated_actions,
        maybe models            => $self->models->[0] ? $self->models : undef,
    };
    #>>>
}


sub validate( $self, $data = undef ) {
    $data //= $self->data;
    return $schema->is_valid( $data );
}


sub to_json($self) {
    return $json->encode( $self->data );
}


sub BUILDARGS( $, @args ) {

    if ( @args == 1 && !ref( $args[0] ) ) {
        unshift @args, "template";
    }

    my %args = ( @args == 1 && ref( $args[0] ) eq "HASH" ) ? $args[0]->%* : @args;

    if ( my $version = $args{version} ) {
        croak "unsupported version '${version}'"
            if PositiveInt->check($version) && $version != 1;
    }


    if ( my $template = delete $args{template} ) {

        my %templates = (

            no_automation => {
                code_generation         => "toolchain",
                automated_contributions => "none",
                automated_actions       => "comment",
              },

              issues_only => {
                code_generation         => "toolchain",
                automated_contributions => "issue",
                automated_actions       => "issue",
              },

              human_supervised => {
                code_generation         => "machine_generated",
                automated_contributions => "code_request",
                automated_actions       => "code_request",
              },

              data_driven_updates => {
                code_generation         => "external_sources",
                automated_contributions => "issue",
                automated_actions       => "release",
              },

              full_automation => {
                code_generation         => "code_generation",
                automated_contributions => "code_request",
                automated_actions       => "release",
              },

        );

        if ( my $match = $templates{$template} ) {

            for my $attr ( keys $match->%* ) {
                $args{$attr} //= $match->{$attr};
            }

        }
        else {
            croak "Unsupported template: '${template}'";
        }


    }

    return \%args;
}


sub from_json( $class, @args ) {


    if ( @args == 1 && !ref( $args[0] ) ) {
        unshift @args, "json";
    }

    my %args = ( @args == 1 && ref( $args[0] ) eq "HASH" ) ? $args[0]->%* : @args;

    croak "json is required" unless defined $args{json};

    $args{json} = $json->decode( $args{json} ) unless ref( $args{json} );

    if ( my $res = $schema->validate( $args{json} ) ) {
        return $class->new( $args{json} );
    }
    else {
        croak $_ for $res->errors;
    }

}

1;

__END__