CI: new check for leftover skips/fixmes

If a PR says "Fixes #123", make sure it removes skips and/or
FIXME comments that reference issue 123.

Signed-off-by: Ed Santiago <santiago@redhat.com>

3 files changed, 332 insertions, 1 deletions

diff --git a/Makefile b/Makefile
index d172f2048..ca4b17d8f 100644
--- a/Makefile
+++ b/Makefile
@@ -264,7 +264,7 @@ codespell:
 	codespell -S bin,vendor,.git,go.sum,.cirrus.yml,"RELEASE_NOTES.md,*.xz,*.gz,*.ps1,*.tar,swagger.yaml,*.tgz,bin2img,*ico,*.png,*.1,*.5,copyimg,*.orig,apidoc.go" -L pullrequest,uint,iff,od,seeked,splitted,marge,erro,hist,ether -w
 
 .PHONY: validate
-validate: lint .gitvalidation validate.completions man-page-check swagger-check tests-included tests-expect-exit
+validate: lint .gitvalidation validate.completions man-page-check swagger-check tests-included tests-expect-exit pr-removes-fixed-skips
 
 .PHONY: build-all-new-commits
 build-all-new-commits:
@@ -621,6 +621,10 @@ tests-expect-exit:
 		exit 1; \
 	fi
 
+.PHONY: pr-removes-fixed-skips
+pr-removes-fixed-skips:
+	contrib/cirrus/pr-removes-fixed-skips
+
 ###
 ### Release/Packaging targets
 ###
diff --git a/contrib/cirrus/pr-removes-fixed-skips b/contrib/cirrus/pr-removes-fixed-skips
new file mode 100755
index 000000000..c4acf6e06
--- /dev/null
+++ b/contrib/cirrus/pr-removes-fixed-skips
@@ -0,0 +1,193 @@
+#!/usr/bin/perl
+#
+# pr-removes-fixed-skips - if PR says "Fixes: #123", no skips should mention 123
+#
+package Podman::CI::PrRemovesFixedSkips;
+
+use v5.14;
+use utf8;
+
+# Grumble. CI system doesn't have 'open'
+binmode STDIN,  ':utf8';
+binmode STDOUT, ':utf8';
+
+use strict;
+use warnings;
+
+(our $ME = $0) =~ s|.*/||;
+our $VERSION = '0.1';
+
+###############################################################################
+# BEGIN boilerplate args checking, usage messages
+
+sub usage {
+    print  <<"END_USAGE";
+Usage: $ME [OPTIONS]
+
+$ME reads a GitHub PR message, looks for
+Fixed/Resolved/Closed issue IDs, then greps for test files
+containing 'Skip' instructions or FIXME comments referencing
+those IDs. If we find any, we abort with a loud and hopefully
+useful message.
+
+$ME is intended to run from Cirrus CI.
+
+OPTIONS:
+
+  --help         display this message
+  --version      display program name and version
+END_USAGE
+
+    exit;
+}
+
+# Command-line options.  Note that this operates directly on @ARGV !
+our $debug   = 0;
+sub handle_opts {
+    use Getopt::Long;
+    GetOptions(
+        'debug!'     => \$debug,
+
+        help         => \&usage,
+        version      => sub { print "$ME version $VERSION\n"; exit 0 },
+    ) or die "Try `$ME --help' for help\n";
+}
+
+# END   boilerplate args checking, usage messages
+###############################################################################
+
+############################## CODE BEGINS HERE ###############################
+
+# The term is "modulino".
+__PACKAGE__->main()                                     unless caller();
+
+# Main code.
+sub main {
+    # Note that we operate directly on @ARGV, not on function parameters.
+    # This is deliberate: it's because Getopt::Long only operates on @ARGV
+    # and there's no clean way to make it use @_.
+    handle_opts();                      # will set package globals
+
+    die "$ME: This script takes no arguments; try $ME --help\n"  if @ARGV;
+
+    # Check commit messages from both github and git; they often differ
+    my @issues = fixed_issues(cirrus_change_message(), git_commit_messages())
+        or exit 0;
+
+    my @found = unremoved_skips(@issues)
+        or exit 0;
+
+    # Found unremoved skips. Fail loudly.
+    my $issues = "issue #$issues[0]";
+    if (@issues > 1) {
+        $issues = "issues #" . join ", #", @issues;
+    }
+
+    warn "$ME: Your PR claims to resolve $issues\n";
+    warn "    ...but does not remove associated Skips/FIXMEs:\n";
+    warn "\n";
+    warn "   $_\n" for @found;
+    warn "\n";
+    warn <<"END_ADVICE";
+Please do not leave Skips or FIXMEs for closed issues.
+
+If an issue is truly fixed, please remove all Skips referencing it.
+
+If an issue is only PARTIALLY fixed, please file a new issue for the
+remaining problem, and update remaining Skips to point to that issue.
+
+And if the issue is fixed but the Skip needs to remain for other
+reasons, again, please update the Skip message accordingly.
+END_ADVICE
+    exit 1;
+}
+
+#####################
+#  unremoved_skips  #  Returns list of <path>:<lineno>:<skip string> matches
+#####################
+sub unremoved_skips {
+    my $issues = join('|', @_);
+
+    my $re = "(^\\s\+skip|fixme).*#($issues)[^0-9]";
+    # FIXME FIXME FIXME: use File::Find instead of enumerating directories
+    # (the important thing here is to exclude vendor)
+    my @grep = ('egrep', '-rin', $re, "test", "cmd", "libpod", "pkg");
+
+    my @skips;
+    open my $grep_fh, '-|', @grep
+        or die "$ME: Could not fork: $!\n";
+    while (my $line = <$grep_fh>) {
+        chomp $line;
+
+        # e.g., test/system/030-run.bats:809:   skip "FIXME: #12345 ..."
+        $line =~ m!^(\S+):\d+:\s!
+            or die "$ME: Internal error: output from grep does not match <path>:<lineno>:<space>: '$line'";
+        my $path = $1;
+
+        # Any .go or .bats file, or the apply-podman-deltas script
+        if ($path =~ /\.(go|bats)$/ || $path =~ m!/apply-podman-deltas$!) {
+            push @skips, $line;
+        }
+
+        # Anything else is probably a backup file, or something else
+        # we don't care about. (We won't see these in CI, but might
+        # in a user devel environment)
+        elsif ($debug) {
+            print "[ ignoring: $line ]\n";
+        }
+    }
+    close $grep_fh;
+
+    return sort @skips;
+}
+
+##################
+#  fixed_issues  #  Parses change message, looks for Fixes/Closes/Resolves
+##################
+sub fixed_issues {
+    my @issues;
+
+    for my $msg (@_) {
+        # https://docs.github.com/en/issues/tracking-your-work-with-issues/linking-a-pull-request-to-an-issue#linking-a-pull-request-to-an-issue-using-a-keyword
+        #
+        #                 1               1              2   2
+        while ($msg =~ /\b(Fix|Clos|Resolv)[esd]*[:\s]+\#(\d+)/gis) {
+            # Skip dups: we're probably checking both github and git messages
+            push @issues, $2
+                unless grep { $_ eq $2 } @issues;
+        }
+    }
+
+    return @issues;
+}
+
+###########################
+#  cirrus_change_message  #  this is the one from *GitHub*, not *git*
+###########################
+sub cirrus_change_message {
+    my $change_message = $ENV{CIRRUS_CHANGE_MESSAGE}
+        or do {
+            # OK for it to be unset if we're not running CI on a PR
+            return if ! $ENV{CIRRUS_PR};
+            # But if we _are_ running on a PR, something went badly wrong.
+            die "$ME: \$CIRRUS_CHANGE_MESSAGE is undefined\n";
+        };
+
+    return $change_message;
+}
+
+#########################
+#  git_commit_messages  #  the ones from the *git history*
+#########################
+sub git_commit_messages {
+    # Probably the same as HEAD, but use Cirrus-defined value if available
+    my $head = $ENV{CIRRUS_CHANGE_IN_REPO} || 'HEAD';
+
+    # Base of this PR. Here we absolutely rely on cirrus.
+    return if ! $ENV{DEST_BRANCH};
+    chomp(my $base = qx{git merge-base $ENV{DEST_BRANCH} $head});
+
+    qx{git log --format=%B $base..$head};
+}
+
+1;
diff --git a/contrib/cirrus/pr-removes-fixed-skips.t b/contrib/cirrus/pr-removes-fixed-skips.t
new file mode 100755
index 000000000..c936892cd
--- /dev/null
+++ b/contrib/cirrus/pr-removes-fixed-skips.t
@@ -0,0 +1,134 @@
+#!/usr/bin/perl -w
+
+# Don't care if these modules don't exist in CI; only Ed runs this test
+use v5.14;
+use Test::More;
+use Test::Differences;
+use File::Basename;
+use File::Path          qw(make_path remove_tree);
+use File::Temp          qw(tempdir);
+use FindBin;
+
+# Simpleminded parser tests. LHS gets glommed together into one long
+# github message; RHS (when present) is the expected subset of issue IDs
+# that will be parsed from it.
+#
+# Again, we glom the LHS into one long multiline string. There doesn't
+# seem to be much point to testing line-by-line.
+my $parser_tests = <<'END_PARSER_TESTS';
+Fixes 100
+Fixes: 101
+Closes 102
+
+Fixes: #103                           | 103
+Fix: #104, #105                       | 104
+Resolves: #106 closes #107            | 106 107
+
+fix: #108, FIXES: #109, FiXeD: #110   | 108 109 110
+Close:   #111 resolved: #112          | 111 112
+END_PARSER_TESTS
+
+
+# Read tests from __END__ section of this script
+my @full_tests;
+while (my $line = <DATA>) {
+    chomp $line;
+
+    if ($line =~ /^==\s+(.*)/) {
+        push @full_tests,
+            { name => $1, issues => [], files => {}, expect => [] };
+    }
+    elsif ($line =~ /^\[([\d\s,]+)\]$/) {
+        $full_tests[-1]{issues} = [ split /,\s+/, $1 ];
+    }
+
+    #                  1     1   23   3 4   4 5  52
+    elsif ($line =~ m!^(\!|\+)\s+((\S+):(\d+):(.*))$!) {
+        push @{$full_tests[-1]{expect}}, $2 if $1 eq '+';
+
+        $full_tests[-1]{files}{$3}[$4] = $5;
+    }
+}
+
+plan tests => 1 + 1 + @full_tests;
+
+require_ok "$FindBin::Bin/pr-removes-fixed-skips";
+
+#
+# Parser tests. Just run as one test.
+#
+my $msg = '';
+my @parser_expect;
+for my $line (split "\n", $parser_tests) {
+    if ($line =~ s/\s+\|\s+([\d\s]+)$//) {
+        push @parser_expect, split ' ', $1;
+    }
+    $msg .= $line . "\n";
+}
+
+my @parsed = Podman::CI::PrRemovesFixedSkips::fixed_issues($msg);
+eq_or_diff \@parsed, \@parser_expect, "parser parses issue IDs";
+
+###############################################################################
+
+#
+# Full tests. Create dummy source-code trees and verify that our check runs.
+#
+my $tmpdir = tempdir(basename($0) . ".XXXXXXXX", TMPDIR => 1, CLEANUP => 1);
+chdir $tmpdir
+    or die "Cannot cd $tmpdir: $!";
+mkdir $_        for qw(cmd libpod pkg test);
+for my $t (@full_tests) {
+    for my $f (sort keys %{$t->{files}}) {
+        my $lineno = 0;
+        make_path(dirname($f));
+        open my $fh, '>', $f or die;
+
+        my @lines = @{$t->{files}{$f}};
+        for my $i (1 .. @lines + 10) {
+            my $line = $lines[$i] || "[line $i intentionally left blank]";
+            print { $fh } $line, "\n";
+        }
+        close $fh
+            or die;
+    }
+
+    # FIXME: run test
+    my @actual = Podman::CI::PrRemovesFixedSkips::unremoved_skips(@{$t->{issues}});
+    eq_or_diff \@actual, $t->{expect}, $t->{name};
+
+    # clean up
+    unlink $_   for sort keys %{$t->{files}};
+}
+
+chdir '/';
+
+__END__
+
+== basic test
+[12345]
+! test/foo/bar/foo.bar:10:   skip "#12345: not a .go file"
++ test/foo/bar/foo.go:17:    skip "#12345: this one should be found"
++ test/zzz/foo.bats:10:   # FIXME: #12345: we detect FIXMEs also
+
+== no substring matches
+[123]
+! test/system/123-foo.bats:12:    skip "#1234: should not match 123"
+! test/system/123-foo.bats:13:    skip "#0123: should not match 123"
+
+== multiple matches
+[456, 789]
++ cmd/podman/foo_test.go:10:    Skip("#456 - blah blah")
+! cmd/podman/foo_test.go:15:    Skip("#567 - not a match")
++ cmd/podman/foo_test.go:19:    Skip("#789 - match 2nd issue")
++ cmd/podman/zzz_test.go:12:    Skip("#789 - in another file")
+
+== no match on bkp files
+[10101]
+! pkg/podman/foo_test.go~:10:    Skip("#10101: no match in ~ file")
+! pkg/podman/foo_test.go.bkp:10:    Skip("#10101: no match in .bkp file")
+
+== no match if Skip is commented out
+[123]
+! test/e2e/foo_test.go:10:   // Skip("#123: commented out")
+! test/system/012-foo.bats:20:      # skip "#123: commented out"