Test-Mapper/lib/Test/Mapper.pm

package Test::Mapper;

use strict;
use warnings;

our $VERSION = '0.001';

#ABSTRACT: Map what parts of a codebase changing ought trigger acceptance tests

=head1 DESCRIPTION

The general tradition in perl unit testing is to map 'what to test' when a piece of code changes is simple:

    lib/Foo/Bar.pm -> t/lib-Foo-Bar.t (or t/lib-Foo/Bar.t)
    bin/baz -> t/bin-baz.t

Unfortunately things tend to get messy when you engage in more complicated testing, such as integration testing.
There, you have one-to-many relationships, but which can still be easily discerned programmatically via inspecting @INC.
That is unless you require() modules (or worse, read & eval/exec), in which case analysis via PPI must be brought to bear.
Still, most people solve that particular problem with the doctor's adage about "not doing things that hurt".

However, acceptance tests will blow out your build server's thinking budget quickly, being a many-to-many mapping.
To make things worse, much of the stack isn't necessarily in $LANGUAGE_OF_CHOICE.
Furthermore this is not something that can simply be avoided via careful structuring.

Knowing all this, what then shall we do?  Cheat.
AKA breaking an insoluble problem into many smaller soluble ones.
It is well within the ability of a test author to discern the route via which an acceptance test accesses a feature.
Indeed this is necessarily so.

As such if we structure our mapping from this perspective life becomes quickly simplified.
Taking as an example an average web application, we can imagine a mapping like:

    t/acceptance/DoFoobarFeature.t -> GET /ez/bez, POST /huth/buth, ...

And every single so loaded "endpoint" necessarily has a number of resources loaded.
It is well within the realm of possibility to hit these endpoints with L<Playwright>, grab a HttpARchive and map that to the relevant source files in the repo.

Similarly one can (in most cases) do the same thing with normal applications via C<ldd>, C<strace> and so forth.

=head1 SYNOPSIS

    use Test::Mapper;

    my $mapper = Test::Mapper->new(
        db          => '/path/to/mapper.db',
        product     => 'MyApp',
        environment => 'linux',
    );

    # Record that a test exercises certain source files
    $mapper->map_test(
        test      => 't/acceptance/login.t',
        resources => [ 'lib/MyApp/Auth.pm', 'lib/MyApp/Session.pm' ],
    );

    # Given a list of changed files, find which tests need to run
    my @tests = $mapper->tests_for_resources(
        resources => [ 'lib/MyApp/Auth.pm' ],
    );

=head1 METHODS

=head2 new(%args)

Constructor. Required args:

=over 4

=item db

Path to the SQLite database file.

=item product

Product name string. Used to namespace data across products in a shared DB.

=item environment

Environment name (e.g. C<linux>, C<MSWin32>). Tests may exercise different
resources on different platforms.

=back

=head2 map_test(%args)

Record that C<test> (a test filename) exercises C<resources> (arrayref of
source filenames). Idempotent — safe to call on every analysis run.

=head2 tests_for_resources(%args)

Given C<resources> (arrayref of changed filenames), return a list of test
filenames that should be run.

=head2 start_build(%args)

Queue tests for a build. Required: C<build> (build identifier, e.g. a git SHA),
C<resources> (arrayref of changed filenames). Returns a list of test filenames
queued for this build.

=head2 pending_tests(%args)

Return unclaimed test filenames for a build. Required: C<build>.

=head2 claim_test(%args)

Atomically claim a test for a worker. Required: C<build>, C<test>, C<worker>.
Returns 1 if claimed, 0 if already claimed by another worker.

=head2 complete_test(%args)

Record a test result. Required: C<build>, C<test>, C<result> (integer; 0=pass,
non-zero=fail convention recommended). Sets finish timestamp automatically.

=head2 build_results(%args)

Return all results for a build as an arrayref of hashrefs, each with keys
C<test_file>, C<run_by>, C<result>, C<start>, C<finish>. Required: C<build>.

=cut

use Test::Mapper::DB;

sub new {
    my ( $class, %args ) = @_;
    die "db is required"          unless $args{db};
    die "product is required"     unless $args{product};
    die "environment is required" unless $args{environment};

    my $dbh = Test::Mapper::DB::dbh( $args{db} );
    my $self = bless {
        dbh         => $dbh,
        product     => $args{product},
        environment => $args{environment},
        _product_id => undef,
        _env_id     => undef,
    }, $class;

    $self->_ensure_product;
    $self->_ensure_environment;

    return $self;
}

sub map_test {
    my ( $self, %args ) = @_;
    die "test is required"      unless $args{test};
    die "resources is required" unless $args{resources};

    my $dbh     = $self->{dbh};
    my $test_id = $self->_ensure_test( $args{test} );

    for my $filename ( @{ $args{resources} } ) {
        my $resource_id = $self->_ensure_resource($filename);
        $dbh->do(
            "INSERT OR IGNORE INTO tested_by (resource_id, test_id) VALUES (?, ?)",
            undef, $resource_id, $test_id
        ) or die "Could not map test: " . $dbh->errstr;
    }

    return;
}

sub tests_for_resources {
    my ( $self, %args ) = @_;
    die "resources is required" unless $args{resources};

    my $dbh = $self->{dbh};
    my $env_id = $self->{_env_id};

    my $placeholders = join( ",", ("?") x scalar @{ $args{resources} } );
    my $sth = $dbh->prepare(
        "SELECT DISTINCT t.filename
         FROM test AS t
         JOIN tested_by AS tb ON tb.test_id = t.id
         JOIN resource AS r ON r.id = tb.resource_id
         WHERE r.environment_id = ?
           AND r.filename IN ($placeholders)"
    ) or die "Could not prepare query: " . $dbh->errstr;

    $sth->execute( $env_id, @{ $args{resources} } )
        or die "Could not execute query: " . $sth->errstr;

    my @tests;
    while ( my ($filename) = $sth->fetchrow_array ) {
        push @tests, $filename;
    }
    return @tests;
}

sub start_build {
    my ( $self, %args ) = @_;
    die "build is required"     unless $args{build};
    die "resources is required" unless $args{resources};

    my $dbh      = $self->{dbh};
    my $build_id = $self->_ensure_build( $args{build} );
    my $env_id   = $self->{_env_id};

    return () unless @{ $args{resources} };

    my $placeholders = join( ",", ("?") x scalar @{ $args{resources} } );
    $dbh->do(
        "INSERT OR IGNORE INTO test_for_build (build_id, test_id)
         SELECT ?, tr.test_id
         FROM to_run AS tr
         WHERE tr.environment = (SELECT environment FROM environment WHERE id = ?)
           AND tr.source_file IN ($placeholders)",
        undef, $build_id, $env_id, @{ $args{resources} }
    ) or die "Could not queue tests for build: " . $dbh->errstr;

    my $sth = $dbh->prepare(
        "SELECT t.filename
         FROM test AS t
         JOIN test_for_build AS tfb ON tfb.test_id = t.id
         WHERE tfb.build_id = ?"
    ) or die "Could not prepare query: " . $dbh->errstr;
    $sth->execute($build_id) or die $sth->errstr;

    my @tests;
    while ( my ($filename) = $sth->fetchrow_array ) {
        push @tests, $filename;
    }
    return @tests;
}

sub pending_tests {
    my ( $self, %args ) = @_;
    die "build is required" unless $args{build};

    my $dbh = $self->{dbh};
    my ($build_id) = $dbh->selectrow_array(
        "SELECT id FROM build WHERE build=? AND product_id=?",
        undef, $args{build}, $self->{_product_id}
    );
    return () unless $build_id;

    my $sth = $dbh->prepare(
        "SELECT t.filename
         FROM test AS t
         JOIN test_for_build AS tfb ON tfb.test_id = t.id
         WHERE tfb.build_id = ? AND tfb.run_by IS NULL"
    ) or die "Could not prepare query: " . $dbh->errstr;
    $sth->execute($build_id) or die $sth->errstr;

    my @tests;
    while ( my ($filename) = $sth->fetchrow_array ) {
        push @tests, $filename;
    }
    return @tests;
}

sub claim_test {
    my ( $self, %args ) = @_;
    die "build is required"  unless $args{build};
    die "test is required"   unless $args{test};
    die "worker is required" unless $args{worker};

    my $dbh      = $self->{dbh};
    my $build_id = $self->_build_id( $args{build} ) // return 0;
    my $test_id  = $self->_test_id( $args{test} )   // return 0;

    my $rows = $dbh->do(
        "UPDATE test_for_build SET run_by=?
         WHERE build_id=? AND test_id=? AND run_by IS NULL",
        undef, $args{worker}, $build_id, $test_id
    );
    return ( $rows && $rows > 0 ) ? 1 : 0;
}

sub complete_test {
    my ( $self, %args ) = @_;
    die "build is required"  unless $args{build};
    die "test is required"   unless $args{test};
    die "result is required" unless defined $args{result};

    my $dbh      = $self->{dbh};
    my $build_id = $self->_build_id( $args{build} ) // die "Unknown build: $args{build}";
    my $test_id  = $self->_test_id( $args{test} )   // die "Unknown test: $args{test}";

    $dbh->do(
        "UPDATE test_for_build SET result=?, finish=CURRENT_TIMESTAMP
         WHERE build_id=? AND test_id=?",
        undef, $args{result}, $build_id, $test_id
    ) or die "Could not complete test: " . $dbh->errstr;
    return;
}

sub build_results {
    my ( $self, %args ) = @_;
    die "build is required" unless $args{build};

    my $dbh = $self->{dbh};
    my $sth = $dbh->prepare(
        "SELECT t.filename, tfb.run_by, tfb.result, tfb.start, tfb.finish
         FROM test_for_build AS tfb
         JOIN test  AS t ON t.id = tfb.test_id
         JOIN build AS b ON b.id = tfb.build_id
         WHERE b.build=? AND b.product_id=?"
    ) or die "Could not prepare query: " . $dbh->errstr;
    $sth->execute( $args{build}, $self->{_product_id} ) or die $sth->errstr;

    my @results;
    while ( my $row = $sth->fetchrow_hashref ) {
        push @results, {
            test_file => $row->{filename},
            run_by    => $row->{run_by},
            result    => $row->{result},
            start     => $row->{start},
            finish    => $row->{finish},
        };
    }
    return \@results;
}

# ---- private helpers ----

sub _ensure_product {
    my ($self) = @_;
    my $dbh = $self->{dbh};
    $dbh->do(
        "INSERT OR IGNORE INTO product (product) VALUES (?)",
        undef, $self->{product}
    ) or die $dbh->errstr;
    my ($id) = $dbh->selectrow_array(
        "SELECT id FROM product WHERE product=?",
        undef, $self->{product}
    );
    $self->{_product_id} = $id;
    return $id;
}

sub _ensure_environment {
    my ($self) = @_;
    my $dbh = $self->{dbh};
    $dbh->do(
        "INSERT OR IGNORE INTO environment (environment, product_id) VALUES (?, ?)",
        undef, $self->{environment}, $self->{_product_id}
    ) or die $dbh->errstr;
    my ($id) = $dbh->selectrow_array(
        "SELECT id FROM environment WHERE environment=? AND product_id=?",
        undef, $self->{environment}, $self->{_product_id}
    );
    $self->{_env_id} = $id;
    return $id;
}

sub _ensure_test {
    my ( $self, $filename ) = @_;
    my $dbh = $self->{dbh};
    $dbh->do(
        "INSERT OR IGNORE INTO test (filename, product_id) VALUES (?, ?)",
        undef, $filename, $self->{_product_id}
    ) or die $dbh->errstr;
    my ($id) = $dbh->selectrow_array(
        "SELECT id FROM test WHERE filename=? AND product_id=?",
        undef, $filename, $self->{_product_id}
    );
    return $id;
}

sub _ensure_build {
    my ( $self, $build ) = @_;
    my $dbh = $self->{dbh};
    $dbh->do(
        "INSERT OR IGNORE INTO build (build, product_id) VALUES (?, ?)",
        undef, $build, $self->{_product_id}
    ) or die $dbh->errstr;
    my ($id) = $dbh->selectrow_array(
        "SELECT id FROM build WHERE build=? AND product_id=?",
        undef, $build, $self->{_product_id}
    );
    return $id;
}

sub _build_id {
    my ( $self, $build ) = @_;
    my ($id) = $self->{dbh}->selectrow_array(
        "SELECT id FROM build WHERE build=? AND product_id=?",
        undef, $build, $self->{_product_id}
    );
    return $id;
}

sub _test_id {
    my ( $self, $filename ) = @_;
    my ($id) = $self->{dbh}->selectrow_array(
        "SELECT id FROM test WHERE filename=? AND product_id=?",
        undef, $filename, $self->{_product_id}
    );
    return $id;
}

sub _ensure_resource {
    my ( $self, $filename ) = @_;
    my $dbh = $self->{dbh};
    $dbh->do(
        "INSERT OR IGNORE INTO resource (environment_id, filename) VALUES (?, ?)",
        undef, $self->{_env_id}, $filename
    ) or die $dbh->errstr;
    my ($id) = $dbh->selectrow_array(
        "SELECT id FROM resource WHERE environment_id=? AND filename=?",
        undef, $self->{_env_id}, $filename
    );
    return $id;
}

1;