path: root/bin/lint-dist

#!/usr/bin/env perl
use strict;
use warnings;
use 5.016;

use Archive::Tar;
use Getopt::Long;
use HTTP::Tiny;
use JSON;
use Parse::CPAN::Meta;
use Parse::CPAN::Packages::Fast;

my @checks = (
    [
        sub { 1 },
        sub { !$_[0]->has_file('META.json') },
        "No META.json file found, using META.yml"
    ],
    [
        sub { 1 },
        sub { !!grep { $_[0]->has_file($_) } qw(MYMETA.yml MYMETA.json) },
        "MYMETA found in dist"
    ],
    [
        sub { 1 },
        sub {
            my $main_module = 'lib/' . ($_[0]->name =~ s/-/\//gr) . '.pm';
            $_[0]->read_file($main_module) =~ /search\.cpan\.org/;
        },
        "module docs link to s.c.o"
    ],
    [
        sub { 1 },
        sub { !$_[0]->has_meta_2 },
        "not using META spec version 2"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub { !grep { $_ eq 'mit' } @{ $_[0]->meta->{license} } },
        "not using the MIT license"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub { $_[0]->meta->{license} ne 'mit' },
        "not using the MIT license"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{bugtracker}{web} // '') !~ /github\.com/
        },
        "not using github issues"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{bugtracker} // '') !~ /github\.com/
        },
        "not using github issues"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{repository}{url} // '') !~ /github\.com/
        },
        "repository not on github"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{repository} // '') !~ /github\.com/
        },
        "repository not on github"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub {
            my $url = ($_[0]->meta->{resources}{repository}{url} // '');
            my $dist_name = $_[0]->name;
            $url !~ /\/\L$dist_name\.git$/;
        },
        "repository named incorrectly"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub {
            my $url = ($_[0]->meta->{resources}{repository} // '');
            my $dist_name = $_[0]->name;
            $url !~ /\/\L$dist_name\.git$/;
        },
        "repository named incorrectly"
    ],
    [
        sub { $_[0]->meta },
        sub {
            my ($author) = grep { /Jesse Luehrs/ } @{ $_[0]->meta->{author} };
            $author && $author !~ /<doy\@tozt\.net>/
        },
        "using the wrong email address"
    ],
    [
        sub { $_[0]->meta },
        sub { !$_[0]->meta->{x_authority} },
        "no AUTHORITY info set"
    ],
    [
        sub { $_[0]->meta },
        sub { $_[0]->meta->{generated_by} !~ /Dist::Zilla/ },
        "not using Dist::Zilla"
    ],
    [
        sub { $_[0]->meta && $_[0]->meta->{generated_by} =~ /Dist::Zilla/ },
        sub {
            $_[0]->meta->{generated_by} !~
                /Dist::Zilla version .*, CPAN::Meta::Converter version .*/
        },
        "using ancient Dist::Zilla"
    ],
    [
        sub { 1 },
        sub { $_[0]->has_file('weaver.ini') },
        "still using weaver.ini"
    ],
    [
        sub { $_[0]->meta && $_[0]->meta->{x_Dist_Zilla} },
        sub {
            !grep { $_->{class} eq 'Dist::Zilla::Plugin::AutoPrereqs' }
                  @{ $_[0]->meta->{x_Dist_Zilla}{plugins} }
        },
        "not using [AutoPrereqs]"
    ],
    [
        sub { $_[0]->meta && $_[0]->meta->{x_Dist_Zilla} },
        sub {
            !grep { $_->{class} eq 'Dist::Zilla::Plugin::ContributorsFromGit' }
                  @{ $_[0]->meta->{x_Dist_Zilla}{plugins} }
        },
        "not using [ContributorsFromGit]"
    ],
    [
        sub { $_[0]->has_file('dist.ini') },
        sub {
            require Config::INI::Reader;
            my $contents = Config::INI::Reader->read_string(
                $_[0]->read_file('dist.ini')
            );
            !exists $contents->{'@DOY'}
            || !exists $contents->{'@DOY'}{':version'}
            || $contents->{'@DOY'}{':version'} < 0.11;
        },
        "not using the latest version of \@DOY"
    ],
    [
        sub { 1 },
        sub {
            grep { $_->get_content =~ m{\A\#!/usr/bin/env perl} }
                 grep { $_->has_content && $_->name !~ /\.t$/ }
                      $_[0]->tar->get_files
        },
        "using #!/usr/bin/env perl"
    ],
    [
        sub { 1 },
        sub {
            my %allowed = map { $_ => 1 } qw(
                00-compile.t
            );
            grep { /\/\d+.*\.t$/ }
                 grep { !$allowed{s/.*\///r} }
                      $_[0]->tar->list_files
        },
        "has tests with numbers"
    ],
    [
        sub { 1 },
        sub {
            grep { $_->get_content =~ /\$ENV{RELEASE_TESTING}/ }
                 grep { $_->has_content && $_->full_path =~ /\/t\/.*\.t$/ }
                      $_[0]->tar->get_files
        },
        "has release tests in t/"
    ],
    [
        sub { 1 },
        sub {
            my $kwalitee = $_[0]->get_json(
                'http://cpants.cpanauthors.org/dist/' . $_[0]->name . '.json'
            );

            # - use_strict and use_warnings don't notice Moose::Exporter, or
            #   things that use Moose::Exporter, so they will give a lot of
            #   false positives
            # - is_prereq isn't something i can control
            # - metayml_declares_perl_version i just don't care about
            my %ignored = map { $_ => 1 } qw(
                use_strict
                use_warnings
                is_prereq
                metayml_declares_perl_version
            );
            my @res = grep { defined }
                      map  { $_->{error} }
                      grep { !$ignored{$_->{key}} }
                      map  { @$_ }
                      @{ $kwalitee->{kwalitee} };
            return unless @res;
            return \@res;
        },
        sub { map { "Kwalitee: $_" } @{ $_[1] } }
    ],
    [
        sub { 1 },
        sub {
            state $rt_data //= $_[0]->get_json(
                'https://rt.cpan.org/Public/bugs-per-dist.json'
            );
            return $rt_data->{$_[0]->name}{counts}{active}

        },
        sub { "has $_[1] bug(s) on rt.cpan.org" }
    ],
    [
        sub { $_[0]->repository && $_[0]->repository =~ m{/github\.com/} },
        sub { !$_[0]->has_github_data },
        "github repository doesn't exist"
    ],
    [
        sub { $_[0]->has_github_data },
        sub { $_[0]->github_data->{open_issues_count} },
        sub { "has $_[1] bug(s) on github issues" }
    ],
    [
        sub { $_[0]->has_github_data },
        sub {
            my $abstract = $_[0]->meta->{abstract} // '';
            my $description = $_[0]->github_data->{description} // '';
            $description ne $abstract;
        },
        sub { "github description doesn't match abstract" }
    ],
    [
        sub { $_[0]->has_github_data },
        sub { !$_[0]->repo_has_file('.gitignore') },
        sub { "repository doesn't contain .gitignore" }
    ],
    [
        sub { $_[0]->has_github_data },
        sub { !$_[0]->repo_has_file('.travis.yml') },
        sub { "repository doesn't contain .travis.yml" }
    ],
    [
        sub { $_[0]->has_github_data && $_[0]->repo_has_file('.travis.yml') },
        sub {
            my $travis = $_[0]->repo_read_file('.travis.yml');
            grep { /cpanm/ && !/build\.log/ } split /\n/, $travis;
        },
        sub { "travis.yml doesn't display build.log on failures" }
    ],
);

package Dist::To::Lint {
    sub new {
        my $class = shift;
        my (%args) = @_;

        $args{lint} = [];

        if ($args{minicpan}) {
            bless { %args }, "Dist::To::Lint::Minicpan";
        }
        else {
            bless { %args }, "Dist::To::Lint::HTTPTiny";
        }
    }

    sub dist { shift->{dist} }
    sub name { shift->dist->dist }
    sub lint { @{ shift->{lint} } }
    sub add_lint {
        my $self = shift;
        push @{ $self->{lint} }, @_;
    }

    sub tarball_name {
        my $self = shift;

        die "tarball_name must be implemented in a subclass";
    }

    sub tar {
        my $self = shift;

        $self->{tar} //= Archive::Tar->new($self->tarball_name);
    }

    sub directory {
        my $self = shift;
        $self->{directory} //= ($self->tar->list_files)[0] =~ s/\/.*//r;
    }

    sub has_file {
        my $self = shift;
        $self->tar->contains_file(join('/', $self->directory, $_[0]));
    }

    sub read_file {
        my $self = shift;
        $self->tar->get_content(join('/', $self->directory, $_[0]));
    }

    sub meta {
        my $self = shift;
        $self->{meta} //= do {
            if ($self->has_file('META.json')) {
                Parse::CPAN::Meta->load_json_string(
                    $self->read_file('META.json')
                );
            }
            elsif ($self->has_file('META.yml')) {
                Parse::CPAN::Meta->load_yaml_string(
                    $self->read_file('META.yml')
                );
            }
            else {
                undef
            }
        };
    }

    sub has_meta_2 {
        my $self = shift;
        $self->meta && ($self->meta->{'meta-spec'}{version} // 0) >= 2
    }

    sub repository {
        my $self = shift;
        return unless $self->meta;
        return $self->has_meta_2
            ? $self->meta->{resources}{repository}{url}
            : $self->meta->{resources}{repository};
    }

    # XXX doesn't handle files not in the repo root
    sub repo_has_file {
        my $self = shift;
        my ($file) = @_;

        my $repo_name =
            $self->repository =~ s{.*://github\.com/(.*?)(?:\.git)?$}{$1}r;

        my $gh_data = $self->github_data;

        my $tree_data = $self->get_json(
            $gh_data->{trees_url} =~ s!{/sha}!/$gh_data->{default_branch}!r
        );

        grep { $_->{path} eq $file } @{ $tree_data->{tree} };
    }

    # XXX doesn't handle files not in the repo root
    sub repo_read_file {
        my $self = shift;
        my ($file) = @_;

        my $repo_name =
            $self->repository =~ s{.*://github\.com/(.*?)(?:\.git)?$}{$1}r;

        my $gh_data = $self->github_data;

        my $tree_data = $self->get_json(
            $gh_data->{trees_url} =~ s!{/sha}!/$gh_data->{default_branch}!r
        );

        my ($url) =
            map { $_->{url} }
            grep { $_->{path} eq $file }
            @{ $tree_data->{tree} };
        my $data = $self->get_json($url);
        die "unknown encoding"
            unless $data->{encoding} eq 'base64';

        require MIME::Base64;
        return MIME::Base64::decode_base64($data->{content});
    }

    sub github_data {
        my $self = shift;

        return unless $self->repository;

        my $repo_name =
            $self->repository =~ s{.*://github\.com/(.*?)(?:\.git)?$}{$1}r;

        return $self->get_json("https://api.github.com/repos/$repo_name");
    }

    sub has_github_data {
        my $self = shift;
        eval { $self->github_data };
    }

    sub report {
        my $self = shift;

        say $self->name;
        say "=====================";

        if ($self->lint) {
            say for $self->lint;
        }
        else {
            say "No issues found";
        }

        STDOUT->flush;
    }

    sub get_json {
        my $self = shift;
        my ($url) = @_;

        my $auth_url = $url;
        if ($url =~ /api\.github\.com/) {
            state $auth //= $self->github_auth;
            $auth_url =~ s{://api\.github\.com}{://$auth\@api.github.com};
        }

        $self->{_json}{$url} //= do {
            my $res = HTTP::Tiny->new->get($auth_url);
            die "couldn't get data for $url ($res->{status}): $res->{content}"
                unless $res->{success};
            warn "$res->{headers}{'x-ratelimit-remaining'}\n"
                if $url =~ /github\.com/;
            JSON->new->utf8->decode($res->{content});
        }
    }

    sub github_auth {
        my $self = shift;

        return '' unless $self->{github_user};

        $self->{github_pass} //= do {
            require Term::ReadKey;

            open my $read, '<', '/dev/tty'
                or die "couldn't get the terminal for reading: $!";
            open my $write, '>', '/dev/tty'
                or die "couldn't get the terminal for reading: $!";
            $write->print("Github API secret: ");
            $write->flush;

            Term::ReadKey::ReadMode(2);
            chomp(my $pass = <$read>);
            Term::ReadKey::ReadMode(0);

            $write->print("\n");

            $pass;
        };

        return join(':',
            map { HTTP::Tiny->_uri_escape($self->{$_}) }
                'github_user', 'github_pass'
        );
    }
}

package Dist::To::Lint::Minicpan {
    our @ISA = ('Dist::To::Lint');

    sub minicpan { shift->{minicpan} }

    sub tarball_name {
        my $self = shift;
        $self->{tarball_name} //=
            $self->minicpan . "/authors/id/" . $self->dist->pathname
    }
}

package Dist::To::Lint::HTTPTiny {
    our @ISA = ('Dist::To::Lint');

    sub tarball_name {
        my $self = shift;
        $self->{tarball_name} //= $self->_fetch_tarball;
    }

    sub _fetch_tarball {
        my $self = shift;

        my $res = HTTP::Tiny->new->get(
            'http://cpan.metacpan.org/authors/id/' . $self->dist->pathname
        );
        die "Couldn't get distribution tarball"
            unless $res->{success};

        require File::Temp;
        my $fh = File::Temp->new;
        $fh->print($res->{content});
        $fh->flush;
        $fh->seek(0, 0);
        $self->{_tar_fh} = $fh;

        return $fh->filename;
    }
}

my ($all, $minicpan, $github_user);
my $cpanid = uc($ENV{USER});
GetOptions(
    'all'           => \$all,
    'minicpan=s'    => \$minicpan,
    'cpanid'        => \$cpanid,
    'github_user=s' => \$github_user,
) or die;

my @dists = $all
    ? (get_all_dists_for($cpanid, $minicpan))
    : (get_info_for_dists(\@ARGV, $minicpan));

for my $dist (@dists) {
    lint_dist($dist, $minicpan, $github_user);
    say '';
}

sub get_all_dists_for {
    my ($cpanid, $minicpan) = @_;

    return sort { fc($a->dist) cmp fc($b->dist) }
           grep { $_->dist ne 'perl' }
           grep { $_->cpanid eq $cpanid }
           _packages($minicpan)->latest_distributions;
}

sub get_info_for_dists {
    my ($dists, $minicpan) = @_;

    my $p = _packages($minicpan);

    return map {
        $p->latest_distribution($_)
            || die "Couldn't find $_ in the index"
    } @$dists;
}

sub _packages {
    my ($minicpan) = @_;

    my ($packages_file, $packages_fh);

    if ($minicpan) {
        $packages_file = "$minicpan/modules/02packages.details.txt.gz";
    }
    else {
        my $res = HTTP::Tiny->new->get(
            'http://cpan.metacpan.org/modules/02packages.details.txt.gz'
        );
        die "Couldn't get package file" unless $res->{success};

        require File::Temp;
        $packages_fh = File::Temp->new;
        $packages_file = $packages_fh->filename;
        $packages_fh->print($res->{content});
        $packages_fh->flush;
    }

    return Parse::CPAN::Packages::Fast->new($packages_file);
}

sub lint_dist {
    my ($dist, $minicpan, $github_user) = @_;

    my $to_lint = Dist::To::Lint->new(
        dist        => $dist,
        minicpan    => $minicpan,
        github_user => $github_user,
    );

    for my $check (@checks) {
        next unless $check->[0]->($to_lint);
        if (my $ret = $check->[1]->($to_lint)) {
            my @messages = ref($check->[2])
                ? $check->[2]->($to_lint, $ret)
                : $check->[2];
            $to_lint->add_lint($_) for @messages;
        }
    }

    $to_lint->report;
}