plugins/fetchcheck.pl

#!/usr/bin/env perl
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use mplib::config qw($CFG);
use mplib::util qw(fail strip_flag_value);
use mplib::version qw(parse_dep_token);
use mplib::resolve qw(init find_portdir try_pkgconf all_ports);
 
# checks that a port's fetch url is actually reachable, and warns when a
# git source looks long-abandoned -- would have caught the dead 2017
# scc mirror (github.com/8l/scc) immediately, instead of after a full
# failed build session. reachability alone wouldn't have been enough
# there (that mirror DOES still clone fine, its content is just broken/
# stale), so a git source also gets a real shallow clone to check its
# last commit's age, not just "does the url resolve."
#
# usage: mp fetchcheck <port...>          -- explicit ports (recommended;
#                                            each one does a real, if
#                                            shallow, network fetch).
#        mp fetchcheck --all              -- every port in the tree; only
#                                            runs with this flag given
#                                            explicitly, since it's a real
#                                            per-port network cost.
#        mp fetchcheck --stale-years=<N>  -- warn threshold (default 3).
#        mp fetchcheck --dir=<root> ...   -- also search <root> (the same
#                                            way CUSTOM_PORTS_DIR already
#                                            is, first, ahead of every
#                                            configured repo).
 
my $flags = mplib::config::parse_flags(\@ARGV);
mplib::config::load($flags);
my $dir = strip_flag_value(\@ARGV, 'dir');
$CFG->{CUSTOM_PORTS} = $dir if defined $dir;
init();
 
my $all = 0;
my $stale_years = 3;
for(my $i = 0; $i < @ARGV; $i = $i + 1)
{
	if($ARGV[$i] eq '--all')
	{
		$all = 1;
		splice(@ARGV, $i, 1);
		$i = $i - 1;
	}
	elsif($ARGV[$i] =~ /^--stale-years=(\d+)$/)
	{
		$stale_years = $1;
		splice(@ARGV, $i, 1);
		$i = $i - 1;
	}
}
fail("usage: mp fetchcheck <port...> [--dir=<root>] | --all [--stale-years=<N>] (pass a port, or --all to check every port in the tree -- a real network fetch per port)")
    unless @ARGV || $all;
 
my @targets;
if(@ARGV)
{
	@targets = map { my $tok = parse_dep_token($_); { name => $_, dir => find_portdir($tok->{name}, $tok->{slot}) } } @ARGV;
}
else
{
	@targets = map { { name => "$_->{cat}/$_->{name}", dir => $_->{dir} } } all_ports();
}
 
# best-effort: a pkg_fetch="git:url[@ref]" field is authoritative when
# present; otherwise pull the first "git clone <url>" or
# curl/wget <url> out of the raw fetch+install text (covers every legacy
# add.sh this tree actually has).
sub extract_url {
	my ($pc) = @_;
	if(($pc->{pkg_fetch} || '') =~ /^git:([^@]+)/) { return ('git', $1); }
	if(($pc->{pkg_fetch} || '') =~ /^tar:([^,]+)/)  { return ('tar', $1); }
	my $text = ($pc->{_phases}{fetch} || '') . ($pc->{_phases}{install} || '');
	if($text =~ /^\s*git\s+clone\s+(.*)$/m)
	{
		# same flag-skipping as mplib::portlint::check_del_cd_mismatch:
		# --depth (and a couple of others) take their value as a
		# SEPARATE next token, unlike --recursive or a --flag=value form.
		my %TAKES_VALUE = map { $_ => 1 } qw(--depth --branch -b);
		my @tok = split ' ', $1;
		while(@tok && $tok[0] =~ /^-/)
		{
			my $flag = shift @tok;
			shift @tok if $TAKES_VALUE{$flag} && @tok;
		}
		return ('git', $tok[0]) if @tok;
	}
	return ('tar', $1) if $text =~ /\b(?:curl\s+-\S*O\S*|wget)\s+(\S+)/;
	return (undef, undef);
}
 
my $seconds_per_year = 365.25 * 24 * 3600;
my ($nchecked, $ndead, $nstale) = (0, 0, 0);
for my $t (@targets)
{
	unless($t->{dir}) { print "err: $t->{name}, no such port.\n"; next; }
	my $pc = try_pkgconf($t->{dir});
	unless($pc) { print "err: $t->{name}, bad pkg.conf.\n"; next; }
	my ($kind, $url) = extract_url($pc);
	unless(defined $url)
	{
		print "warn: $t->{name}, no fetch url found to check (unusual add.sh shape?).\n";
		next;
	}
	$nchecked = $nchecked + 1;
	if($kind eq 'tar')
	{
		my $code = `curl -sI -o /dev/null -w '%{http_code}' --max-time 20 -L \Q$url\E 2>/dev/null`;
		if($code =~ /^2\d\d$/)
		{
			print "ok: $t->{name}, $url ($code).\n";
		}
		else
		{
			$ndead = $ndead + 1;
			print "err: $t->{name}, $url -- http $code.\n";
		}
		next;
	}
	# git: a real (throwaway, shallow) clone -- ls-remote alone can't
	# report a commit DATE (only refs), and staleness is exactly the
	# thing a pure reachability check misses (the scc mirror this
	# session clones just fine; its content is simply 8 years stale).
	my $tmp = "/tmp/.mp-fetchcheck.$$";
	system("rm -rf \Q$tmp\E");
	my $rc = system("git clone --quiet --depth 1 \Q$url\E \Q$tmp\E >/dev/null 2>&1");
	if($rc != 0)
	{
		$ndead = $ndead + 1;
		print "err: $t->{name}, $url -- not reachable (git clone failed).\n";
		next;
	}
	chomp(my $date = `cd \Q$tmp\E && git log -1 --format=%ci 2>/dev/null`);
	system("rm -rf \Q$tmp\E");
	my $age_years;
	if($date =~ /^(\d{4})-(\d{2})-(\d{2})/)
	{
		require Time::Local;
		my $then = Time::Local::timegm(0, 0, 0, $3, $2 - 1, $1);
		$age_years = (time() - $then) / $seconds_per_year;
	}
	if(defined $age_years && $age_years >= $stale_years)
	{
		$nstale = $nstale + 1;
		printf "warn: %s, %s -- reachable, but last commit is %.1f years old (%s). possibly abandoned upstream.\n",
		    $t->{name}, $url, $age_years, $date;
	}
	else
	{
		print "ok: $t->{name}, $url" . (defined $date && $date ne '' ? " (last commit $date)" : '') . ".\n";
	}
}
print "\n$nchecked url(s) checked, $ndead unreachable, $nstale possibly abandoned.\n";
exit(1) if $ndead;