diff options
Diffstat (limited to 'commands')
| -rw-r--r-- | commands/reporting-harness.pm | 517 | ||||
| -rw-r--r-- | commands/reporting-html-reports.pm | 1262 | ||||
| -rw-r--r-- | commands/reporting-lintian-harness.pm | 603 | ||||
| -rw-r--r-- | commands/reporting-sync-state.pm | 572 |
4 files changed, 2954 insertions, 0 deletions
diff --git a/commands/reporting-harness.pm b/commands/reporting-harness.pm new file mode 100644 index 0000000..89bf2c6 --- /dev/null +++ b/commands/reporting-harness.pm @@ -0,0 +1,517 @@ +#!/usr/bin/perl +# +# Lintian reporting harness -- Create and maintain Lintian reports automatically +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# +# This program is free software. It is distributed under the terms of +# the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package reporting_harness; + +use v5.20; +use warnings; +use utf8; + +use constant BACKLOG_PROCESSING_GROUP_LIMIT => 1024; + +use Date::Format qw(time2str); +use File::Copy; +use FileHandle; +use Getopt::Long; +use Path::Tiny; +use POSIX qw(strftime); +use YAML::XS (); + +use Lintian::IO::Async qw(safe_qx); +use Lintian::Processable; +use Lintian::Relation::Version qw(versions_comparator); +use Lintian::Reporting::Util qw(load_state_cache save_state_cache); +use Lintian::Util qw(open_gz); + +use constant EMPTY => q{}; + +sub usage { + print <<END; +Lintian reporting harness +Create and maintain Lintian reports automatically + +Usage: harness [ -i | -f | -r | -c ] + +Options: + -c clean mode, erase everything and start from scratch (implies -f) + -f full mode, blithely overwrite lintian.log + -i incremental mode, use old lintian.log data, process changes only + -r, --[no-]generate-reports + Whether to generate reports. By default, reports will be + generated at the end of a run with -i, -f or -c. It can also be + used as a standard alone "mode", where only reports are + regenerated. + --reporting-config FILE + Parse FILE as the primary configuration file. Defines which + archives to process, etc. (Default: ./config.yaml) + --dry-run pretend to do the actions without actually doing them. The + "normal" harness output will go to stdout rather than the + harness.log. + --to-stdout + [For debugging] Have output go to stdout as well as the usual + log files. Note, this option has no (extra) effect with --dry-run. + --schedule-chunk-size N + Schedule at most N groups in a given run of Lintian. If more than N + groups need to be processed, harness will invoke Lintian more than + once. If N is 0, schedule all groups in one go. (Default: 512) + --schedule-limit-groups N + Schedule at most N groups in this run of harness. If more than N + groups need to be processed, harness leave the rest for a subsequent + run. (Default: ${\BACKLOG_PROCESSING_GROUP_LIMIT}) + +Incremental mode is the default if you have a lintian.log; +otherwise, it's full. + +Report bugs to <lintian-maint\@debian.org>. +END + #'/# for cperl-mode + exit; +} + +my %opt = ( + 'schedule-chunk-size' => 512, + 'schedule-limit-groups' => BACKLOG_PROCESSING_GROUP_LIMIT, + 'reporting-config' => './config.yaml', +); + +my %opthash = ( + 'i' => \$opt{'incremental-mode'}, + 'c' => \$opt{'clean-mode'}, + 'f' => \$opt{'full-mode'}, + 'generate-reports|r!' => \$opt{'generate-reports'}, + 'reporting-config=s'=> \$opt{'reporting-config'}, + 'dry-run' => \$opt{'dry-run'}, + 'schedule-chunk-size=i' => \$opt{'schedule-chunk-size'}, + 'schedule-limit-groups=i' => \$opt{'schedule-limit-groups'}, + 'to-stdout' => \$opt{'to-stdout'}, + 'help|h' => \&usage, +); + +# Global variables +my ( + $log_file, $lintian_log, $lintian_perf_log, + $html_reports_log,$sync_state_log, $lintian_cmd, + $STATE_DIR, $LINTIAN_VERSION, $LOG_FD, + $CONFIG,$LOG_DIR, $HTML_DIR, + $HTML_TMP_DIR,$LINTIAN_SCRATCH_SPACE, $LINTIAN_BASE, + $EXTRA_LINTIAN_OPTIONS, +); + +sub required_cfg_value { + my (@keys) = @_; + my $v = $CONFIG; + for my $key (@keys) { + if (not exists($v->{$key})) { + my $k = join('.', @keys); + die("Missing required config parameter: ${k}\n"); + } + $v = $v->{$key}; + } + return $v; +} + +sub required_cfg_list_value { + my (@keys) = @_; + my $v = required_cfg_value(@keys); + if (not defined($v) or ref($v) ne 'ARRAY') { + my $k = join('.', @keys); + die("Invalid configuration: ${k} must be a (possibly empty) list\n"); + } + return $v; +} + +sub main { + parse_options_and_config(); + + # turn file buffering off + STDOUT->autoflush; + + unless ($opt{'dry-run'}) { + # rotate log files + my @rotate_logs + = ($log_file, $html_reports_log, $lintian_perf_log, $sync_state_log); + safe_qx('savelog', @rotate_logs); + + # create new log file + open($LOG_FD, '>', $log_file) + or die("cannot open log file $log_file for writing: $!"); + $LOG_FD->autoflush; + } else { + $opt{'to-stdout'} = 0; + open($LOG_FD, '>&', \*STDOUT) + or die "Cannot open log file <stdout> for writing: $!"; + Log('Running in dry-run mode'); + } + # From here on we can use Log() and Die(). + if (not $opt{'dry-run'} and $opt{'clean-mode'}) { + Log('Purging old state-cache/dir'); + path($STATE_DIR)->remove_tree; + } + + if (not -d $STATE_DIR) { + path($STATE_DIR)->mkpath; + Log("Created cache dir: $STATE_DIR"); + } + + if ( !$opt{'generate-reports'} + && !$opt{'full-mode'} + && !$opt{'incremental-mode'}) { + # Nothing explicitly chosen, default to -i if the log is present, + # otherwise -f. + if (-f $lintian_log) { + $opt{'incremental-mode'} = 1; + } else { + $opt{'full-mode'} = 1; + } + } + + # Default to yes, if not explicitly disabled. + $opt{'generate-reports'} //= 1; + + if ($opt{'incremental-mode'} or $opt{'full-mode'}) { + run_lintian(); + } + + if ($opt{'generate-reports'}) { + generate_reports(); + } + + # ready!!! :-) + Log('All done.'); + exit 0; +} + +# ------------------------------- + +sub parse_options_and_config { + + # init commandline parser + Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev'); + + # process commandline options + GetOptions(%opthash) + or die("error parsing options\n"); + + # clean implies full - do this as early as possible, so we can just + # check $opt{'full-mode'} rather than a full + # ($opt{'clean-mode'} || $opt{'full-mode'}) + $opt{'full-mode'} = 1 if $opt{'clean-mode'}; + + die("Cannot use both incremental and full/clean.\n") + if $opt{'incremental-mode'} && $opt{'full-mode'}; + die("The argument for --schedule-limit-groups must be an > 0\n") + if $opt{'schedule-limit-groups'} < 1; + if (not $opt{'reporting-config'} or not -f $opt{'reporting-config'}) { + die("The --reporting-config parameter must point to an existing file\n" + ); + } + # read configuration + $CONFIG = YAML::XS::LoadFile($opt{'reporting-config'}); + $LOG_DIR = required_cfg_value('storage', 'log-dir'); + $HTML_DIR = required_cfg_value('storage', 'reports-dir'); + $HTML_TMP_DIR = required_cfg_value('storage', 'reports-work-dir'); + $STATE_DIR = required_cfg_value('storage', 'state-cache'); + $LINTIAN_SCRATCH_SPACE = required_cfg_value('storage', 'scratch-space'); + + if ( exists($CONFIG->{'lintian'}) + && exists($CONFIG->{'lintian'}{'extra-options'})) { + $EXTRA_LINTIAN_OPTIONS + = required_cfg_list_value('lintian', 'extra-options'); + } else { + $EXTRA_LINTIAN_OPTIONS = []; + } + + $LINTIAN_BASE = $ENV{'LINTIAN_BASE'}; + + $lintian_cmd = "$LINTIAN_BASE/bin/lintian"; + + $LINTIAN_VERSION= safe_qx("$LINTIAN_BASE/bin/lintian",'--print-version'); + chomp($LINTIAN_VERSION); + + ( + $log_file, $lintian_log, $lintian_perf_log,$html_reports_log, + $sync_state_log + ) + = map {"$LOG_DIR/$_" } + qw(harness.log lintian.log lintian-perf.log html_reports.log sync_state.log); + + return; +} + +sub run_lintian { + my @sync_state_args = ( + '--reporting-config', $opt{'reporting-config'}, + '--desired-version', $LINTIAN_VERSION,'--debug', + ); + my @lintian_harness_args = ( + '--lintian-frontend', "$LINTIAN_BASE/bin/lintian", + '--lintian-log-dir', $LOG_DIR, + '--schedule-chunk-size', $opt{'schedule-chunk-size'}, + '--schedule-limit-groups', $opt{'schedule-limit-groups'}, + '--state-dir', $STATE_DIR, + # Finish with the lintian command-line + '--', @{$EXTRA_LINTIAN_OPTIONS}); + + if ($opt{'full-mode'}) { + push(@sync_state_args, '--reschedule-all'); + } + if ($opt{'dry-run'}) { + push(@sync_state_args, '--dry-run'); + } + + if ($LINTIAN_SCRATCH_SPACE) { + unshift(@lintian_harness_args, + '--lintian-scratch-space', $LINTIAN_SCRATCH_SPACE); + } + + Log('Updating harness state cache (reading mirror index files)'); + + my $loop = IO::Async::Loop->new; + my $syncdone = $loop->new_future; + + my @synccommand = ($lintian_cmd, 'reporting-sync-state', @sync_state_args); + Log('Command: ' . join(' ', @synccommand)); + + my $syncprocess = IO::Async::Process->new( + command => [@synccommand], + stdout => { via => 'pipe_read' }, + stderr => { via => 'pipe_read' }, + on_finish => sub { + my ($self, $exitcode) = @_; + my $status = ($exitcode >> 8); + + if ($status) { + Log("warning: executing reporting-sync-state returned $status" + ); + my $message= "Non-zero status $status from @synccommand"; + $syncdone->fail($message); + return; + } + + $syncdone->done("Done with @synccommand"); + return; + }); + + my $syncfh = *STDOUT; + unless($opt{'dry-run'}) { + open($syncfh, '>', $sync_state_log) + or die "Could not open file '$sync_state_log': $!"; + } + + $syncprocess->stdout->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + if (length $$buffref) { + print {$syncfh} $$buffref; + $$buffref = EMPTY; + } + + if ($eof) { + close($syncfh) + unless $opt{'dry-run'}; + } + + return 0; + }, + ); + + $syncprocess->stderr->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + if (length $$buffref) { + print STDERR $$buffref; + $$buffref = EMPTY; + } + + return 0; + }, + ); + + $loop->add($syncprocess); + $syncdone->await; + + Log('Running lintian (via reporting-lintian-harness)'); + Log( + 'Command: ' + . join(' ', + $lintian_cmd, 'reporting-lintian-harness',@lintian_harness_args)); + my %harness_lintian_opts = ( + 'pipe_out' => FileHandle->new, + 'err' => '&1', + 'fail' => 'never', + ); + + if (not $opt{'dry-run'}) { + spawn(\%harness_lintian_opts, + [$lintian_cmd, 'reporting-lintian-harness', @lintian_harness_args] + ); + my $child_out = $harness_lintian_opts{'pipe_out'}; + while (my $line = <$child_out>) { + chomp($line); + Log_no_ts($line); + } + close($child_out); + if (not reap(\%harness_lintian_opts)) { + my $exit_code = $harness_lintian_opts{harness}->full_result; + my $res = ($exit_code >> 8) & 0xff; + my $sig = $exit_code & 0xff; + # Exit code 2 is "time-out", 3 is "lintian got signalled" + # 255 => reporting-lintian-harness caught an unhandled trappable + # error. + if ($res) { + if ($res == 255) { + Die('Lintian harness died with an unhandled exception'); + } elsif ($res == 3) { + Log('Lintian harness stopped early due to signal'); + if ($opt{'generate-reports'}) { + Log('Skipping report generation'); + $opt{'generate-reports'} = 0; + } + } elsif ($res != 2) { + Die("Lintian harness terminated with code $res"); + } + } elsif ($sig) { + Die("Lintian harness was killed by signal $sig"); + } + } + } + return; +} + +sub generate_reports { + my @html_reports_args + = ('--reporting-config',$opt{'reporting-config'},$lintian_log,); + # create html reports + Log('Creating HTML reports...'); + Log("Executing $lintian_cmd reporting-html-reports @html_reports_args"); + + my $loop = IO::Async::Loop->new; + my $htmldone = $loop->new_future; + + my @htmlcommand + = ($lintian_cmd, 'reporting-html-reports', @html_reports_args); + my $htmlprocess = IO::Async::Process->new( + command => [@htmlcommand], + stdout => { via => 'pipe_read' }, + stderr => { via => 'pipe_read' }, + on_finish => sub { + my ($self, $exitcode) = @_; + my $status = ($exitcode >> 8); + + if ($status) { + Log( +"warning: executing reporting-html-reports returned $status" + ); + my $message= "Non-zero status $status from @htmlcommand"; + $htmldone->fail($message); + return; + } + + $htmldone->done("Done with @htmlcommand"); + return; + }); + + open(my $htmlfh, '>', $html_reports_log) + or die "Could not open file '$html_reports_log': $!"; + + $htmlprocess->stdout->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + if (length $$buffref) { + print {$htmlfh} $$buffref; + $$buffref = EMPTY; + } + + close($htmlfh) + if $eof; + + return 0; + }, + ); + + $htmlprocess->stderr->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + if (length $$buffref) { + print STDERR $$buffref; + $$buffref = EMPTY; + } + + return 0; + }, + ); + + $loop->add($htmlprocess); + $htmldone->await; + + Log(''); + + # rotate the statistics file updated by reporting-html-reports + if (!$opt{'dry-run'} && -f "$STATE_DIR/statistics") { + my $date = time2str('%Y%m%d', time()); + my $dest = "$LOG_DIR/stats/statistics-${date}"; + copy("$STATE_DIR/statistics", $dest) + or Log('warning: could not rotate the statistics file'); + } + + # install new html directory + Log('Installing HTML reports...'); + unless ($opt{'dry-run'}) { + path($HTML_DIR)->remove_tree; + # a tiny bit of race right here + rename($HTML_TMP_DIR,$HTML_DIR) + or Die("error renaming $HTML_TMP_DIR into $HTML_DIR"); + } + Log(''); + return; +} + +sub Log { + my ($msg) = @_; + my $ts = strftime('[%FT%T]', localtime()); + Log_no_ts("${ts}: ${msg}"); + return; +} + +sub Log_no_ts { + my ($msg) = @_; + print {$LOG_FD} $msg,"\n"; + print $msg, "\n" if $opt{'to-stdout'}; + return; +} + +sub Die { + Log("fatal error: $_[0]"); + exit 1; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/commands/reporting-html-reports.pm b/commands/reporting-html-reports.pm new file mode 100644 index 0000000..2505538 --- /dev/null +++ b/commands/reporting-html-reports.pm @@ -0,0 +1,1262 @@ +#!/usr/bin/perl -w +# +# Lintian HTML reporting tool -- Create Lintian web reports +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# +# This program is free software. It is distributed under the terms of +# the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package reporting_html_reports; + +use v5.20; +use warnings; +use utf8; +use autodie; + +use Getopt::Long; +use POSIX qw(strftime); +use File::Copy qw(copy); +use Fcntl qw(SEEK_SET); +use List::Util qw(first); +use List::MoreUtils qw(uniq); +use Path::Tiny; +use Text::Template (); +use URI::Escape; +use YAML::XS (); + +use Lintian::Data; +use Lintian::Deb822::Parser qw(read_dpkg_control_lc); +use Lintian::IO::Async qw(safe_qx); +use Lintian::Profile; +use Lintian::Relation::Version qw(versions_comparator); +use Lintian::Reporting::ResourceManager; +use Lintian::Reporting::Util qw(load_state_cache find_backlog); +use Lintian::Util qw(copy_dir run_cmd locate_executable); + +my $CONFIG; +my %OPT; +my %OPT_HASH = ('reporting-config=s'=> \$OPT{'reporting-config'},); + +# ------------------------------ +# Global variables and configuration + +# Some globals initialised in init_global() +my ( + $RESOURCE_MANAGER, $LINTIAN_VERSION, $timestamp, + $TEMPLATE_CONFIG_VARS,$HARNESS_STATE_DIR, $HISTORY_DIR, + $HISTORY, $GRAPHS, $LINTIAN_BASE, + $HTML_TMP_DIR, $SCOUR_ENABLED, +); +# FIXME: Should become obsolete if gnuplot is replaced by R like piuparts.d.o / +# reproducible.d.n is using +my $GRAPHS_RANGE_DAYS = 366; + +# ------------------------------ +# Initialize templates + +# This only has to be done once, so do it at the start and then reuse the same +# templates throughout. +our %templates; + +# %statistics accumulates global statistics. For tags: errors, warnings, +# experimental, overridden, and info are the keys holding the count of tags of +# that sort. For packages: binary, udeb, and source are the number of +# packages of each type with Lintian errors or warnings. For maintainers: +# maintainers is the number of maintainers with Lintian errors or warnings. +# +# %tag_statistics holds a hash of tag-specific statistics. Each tag name is a +# key, and its value is a hash with the following keys: count and overrides +# (number of times the tag has been detected and overridden, respectively), and +# packages (number of packages with at least one such tag). +my (%statistics, %tag_statistics); + +# %by_maint holds a hash of maintainer names to packages and tags. Each +# maintainer is a key. The value is a hash of package names to hashes. Each +# package hash is in turn a hash of versions to an anonymous array of hashes, +# with each hash having keys code, package, type, tag, severity, +# extra, and xref. xref gets the partial URL of the maintainer page for that +# source package. +# +# In other words, the lintian output line: +# +# W: gnubg source: substvar-source-version-is-deprecated gnubg-data +# +# for gnubg 0.15~20061120-1 maintained by Russ Allbery <rra@debian.org> is +# turned into the following structure: +# +# { 'gnubg' => { +# '0.15~20061120-1' => [ +# { code => 'W', # Either 'O' or same as $tag_info->code +# pkg_info => { +# package => 'gnubg', +# version => '0.15~20061120-1', +# component => 'main', +# type => 'source', +# anchor => 'gnubg_0.15~20061120-1', +# xref => 'rra@debian.org.html#gnubg_0.15~20061120-1' +# }, +# tag_info => $tag_info, # an instance of Lintian::Tag::Info +# archs => { +# # Architectures we have seen this tag for +# 'amd64' => 1, +# 'i386' => 1, +# }, +# extra => 'gnubg-data' +# } ] } } +# +# and then stored under the key 'Russ Allbery <rra@debian.org>' +# +# %by_uploader holds the same thing except for packages for which the person +# is only an uploader. +# +# %by_tag is a hash of tag names to an anonymous array of tag information +# hashes just like the inside-most data structure above. +my (%by_maint, %by_uploader, %by_tag, %maintainer_table, %delta); +my @attrs = qw(maintainers source-packages binary-packages udeb-packages + errors warnings info experimental pedantic overridden groups-known + groups-backlog classifications groups-with-errors); + +my @RESTRICTED_CONFIG_DIRS= split(/:/, $ENV{'LINTIAN_RESTRICTED_CONFIG_DIRS'}); +my @CONFIG_DIRS = split(/:/, $ENV{'LINTIAN_CONFIG_DIRS'}); + +sub load_profile { + my ($profile_name, $options) = @_; + my %opt = ( + 'restricted-search-dirs' => \@RESTRICTED_CONFIG_DIRS, + %{$options // {}}, + ); + require Lintian::Profile; + + my $profile = Lintian::Profile->new; + $profile->load($profile_name, \@CONFIG_DIRS, \%opt); + + return $profile; +} + +sub required_cfg_value { + my (@keys) = @_; + my $v = $CONFIG; + for my $key (@keys) { + if (not exists($v->{$key})) { + my $k = join('.', @keys); + die("Missing required config parameter: ${k}\n"); + } + $v = $v->{$key}; + } + return $v; +} + +sub required_cfg_non_empty_list_value { + my (@keys) = @_; + my $v = required_cfg_value(@keys); + if (not defined($v) or ref($v) ne 'ARRAY' or scalar(@{$v}) < 1) { + my $k = join('.', @keys); + die("Invalid configuration: ${k} must be a non-empty list\n"); + } + return $v; +} + +# ------------------------------ +# Main routine + +sub main { + my $profile = init_globals(); + + setup_output_dir( + 'output_dir' => $HTML_TMP_DIR, + 'lintian_manual' => "${LINTIAN_BASE}/doc/lintian.html", + 'lintian_api_docs' => "${LINTIAN_BASE}/doc/api.html", + 'lintian_log_file' => $ARGV[0], + 'resource_dirs' => + [map { "${LINTIAN_BASE}/reporting/$_"} qw(images resources)], + ); + + load_templates("$LINTIAN_BASE/reporting/templates"); + + # Create lintian.css from a template, install the output file as a resource + # and discard the original output file. We do this after installing all + # resources, so the .css file can refer to resources. + output_template( + 'lintian.css', + $templates{'lintian.css'}, + { 'path_prefix' => '../' }); + $RESOURCE_MANAGER->install_resource("$HTML_TMP_DIR/lintian.css"); + + my $state_cache = load_state_cache($HARNESS_STATE_DIR); + + print "Parsing lintian log...\n"; + parse_lintian_log($profile, $state_cache); + + process_data($profile, $state_cache); + exit(0); +} + +# ------------------------------ +# Utility functions + +sub init_globals { + Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev'); + Getopt::Long::GetOptions(%OPT_HASH) or die("error parsing options\n"); + + if (not $OPT{'reporting-config'} or not -f $OPT{'reporting-config'}) { + die("The --reporting-config parameter must point to an existing file\n" + ); + } + $LINTIAN_BASE = $ENV{'LINTIAN_BASE'}; + + $CONFIG = YAML::XS::LoadFile($OPT{'reporting-config'}); + $HARNESS_STATE_DIR = required_cfg_value('storage', 'state-cache'); + $HTML_TMP_DIR = required_cfg_value('storage', 'reports-work-dir'); + my $history_key = 'storage.historical-data-dir'; + if (exists($CONFIG->{'storage'}{'historical-data-dir'})) { + $HISTORY = 1; + $HISTORY_DIR = required_cfg_value('storage', 'historical-data-dir'); + print "Enabling history tracking as ${history_key} is set\n"; + if (length locate_executable('gnuplot')) { + $GRAPHS = 1; + print "Enabling graphs (gnuplot is in PATH)\n"; + } else { + $GRAPHS = 0; + print "No graphs as \"gnuplot\" is not in PATH\n"; + } + if ($GRAPHS) { + if (locate_executable('scour')) { + $SCOUR_ENABLED = 1; + print "Minimizing generated SVG files (scour is in PATH)\n"; + } else { + $SCOUR_ENABLED = 0; + print 'No minimization of generated SVG files' + . " as \"scour\" is not in PATH\n"; + } + } + } else { + $HISTORY = 0; + $GRAPHS = 0; + print "History tracking is disabled (${history_key} is unset)\n"; + print "Without history tracking, there will be no graphs\n"; + } + + if (exists($CONFIG->{'template-variables'})) { + $TEMPLATE_CONFIG_VARS = $CONFIG->{'template-variables'}; + } else { + $TEMPLATE_CONFIG_VARS = {}; + } + # Provide a default URL for the source code. It might not be correct for + # the given installation, but it is better than nothing. + $TEMPLATE_CONFIG_VARS->{'LINTIAN_SOURCE'} + //= 'https://salsa.debian.org/lintian/lintian.git'; + + my $profile = load_profile(); + + Lintian::Data->set_vendor($profile); + + $LINTIAN_VERSION = $ENV{LINTIAN_VERSION}; + $timestamp = safe_qx(qw(date -u --rfc-822)); + chomp($LINTIAN_VERSION, $timestamp); + + $RESOURCE_MANAGER + = Lintian::Reporting::ResourceManager->new('html_dir' => $HTML_TMP_DIR,); + return $profile; +} + +sub load_templates { + my ($template_dir) = @_; + for my $template ( + qw/head foot clean index maintainer maintainers packages tag + tags tags-severity tag-not-seen tags-all/ + ) { + open(my $fd, '<:encoding(UTF-8)', "${template_dir}/$template.tmpl"); + my %options = (TYPE => 'FILEHANDLE', SOURCE => $fd); + $templates{$template} = Text::Template->new(%options) + or die "cannot load template $template: $Text::Template::ERROR\n"; + close($fd); + } + + open(my $fd, '<:encoding(UTF-8)', "${template_dir}/lintian.css.tmpl"); + $templates{'lintian.css'} = Text::Template->new( + TYPE => 'FILEHANDLE', + SOURCE => $fd, + DELIMITERS => ['{{{', '}}}'], + ) + or die("cannot load template for lintian.css: $Text::Template::ERROR\n"); + close($fd); + return; +} + +sub process_data { + my ($profile, $state_cache) = @_; + my @maintainers = sort(uniq(keys(%by_maint), keys(%by_uploader))); + my $statistics_file = "$HARNESS_STATE_DIR/statistics"; + my ($old_statistics, $archives, @archive_info); + + { + # Scoped to allow memory to be re-purposed. The %qa and %sources + # structures are only used for a very few isolated items. + my (%qa, %sources); + print "Collecting statistics...\n"; + $old_statistics + = collect_statistics($profile, $state_cache, $statistics_file, + \@maintainers,\%sources, \%qa); + + generate_lookup_tables(\%sources); + + write_qa_list(\%qa); + + generate_package_index_packages(\%sources); + + if ($HISTORY) { + update_history_and_make_graphs(\@attrs, \%statistics, + \%tag_statistics); + } + } + + # Build a hash of all maintainers, not just those with Lintian tags. We + # use this later to generate stub pages for maintainers whose packages are + # all Lintian-clean. + my %clean; + for my $group_id (sort(keys(%{$state_cache->{'groups'}}))) { + my $maintainer + = $state_cache->{'groups'}{$group_id}{'mirror-metadata'} + {'maintainer'}; + my $id; + next if not $maintainer; + $id = maintainer_url($maintainer); + $clean{$id} = $maintainer; + } + + # Now, walk through the tags by source package (sorted by maintainer). + # Output a summary page of errors and warnings for each maintainer, output + # a full page that includes info, experimental, and overridden tags, and + # assemble the maintainer index and the QA package list as we go. + + for my $maintainer (@maintainers) { + my $id = maintainer_url($maintainer); + delete $clean{$id}; + + # Determine if the maintainer's page is clean. Check all packages for + # which they're either maintainer or uploader and set $error_clean if + # they have no errors or warnings. + # + # Also take this opportunity to sort the tags so that all similar tags + # will be grouped, which produces better HTML output. + my $error_clean = 1; + for my $source ( + keys %{ $by_maint{$maintainer} }, + keys %{ $by_uploader{$maintainer} } + ) { + my $versions = $by_maint{$maintainer}{$source} + || $by_uploader{$maintainer}{$source}; + for my $version (keys %$versions) { + $versions->{$version} + = [sort by_tag @{ $versions->{$version} }]; + next if not $error_clean; + my $tags = $versions->{$version}; + for my $tag (@$tags) { + if ($tag->{code} eq 'E' or $tag->{code} eq 'W') { + $error_clean = 0; + last; + } + } + } + } + + # Determine the parts of the maintainer and the file name for the + # maintainer page. + my ($name, $email) = extract_name_and_email($maintainer); + + my $regular = "maintainer/$id"; + my $full = "full/$id"; + + # Create the regular maintainer page (only errors and warnings) and the + # full maintainer page (all tags, including overrides and info tags). + print "Generating page for $id\n"; + my $q_name = html_quote($name); + my %data = ( + email => html_quote(uri_escape($email)), + errors => 1, + id => $id, + maintainer => html_quote($maintainer), + name => $q_name, + packages => $by_maint{$maintainer}, + uploads => $by_uploader{$maintainer}, + ); + my $template; + if ($error_clean) { + $template = $templates{clean}; + } else { + $template = $templates{maintainer}; + } + output_template($regular, $template, \%data); + $template = $templates{maintainer}; + $data{errors} = 0; + output_template($full, $template, \%data); + + my %index_data = (url => $id, name => $q_name); + # Add this maintainer to the hash of maintainer to URL mappings. + $maintainer_table{$maintainer} = \%index_data; + } + undef(@maintainers); + + # Write out the maintainer index. + my %data = (maintainers => \%maintainer_table,); + output_template('maintainers.html', $templates{maintainers}, \%data); + + # Now, generate stub pages for every maintainer who has only clean + # packages. + for my $id (keys %clean) { + my $maintainer = $clean{$id}; + my ($name, $email) = extract_name_and_email($maintainer); + my %maint_data = ( + id => $id, + email => html_quote(uri_escape($email)), + maintainer => html_quote($maintainer), + name => html_quote($name), + clean => 1, + ); + print "Generating clean page for $id\n"; + output_template("maintainer/$id", $templates{clean}, \%maint_data); + output_template("full/$id", $templates{clean}, \%maint_data); + } + + # Create the pages for each tag. Each page shows the extended description + # for the tag and all the packages for which that tag was issued. + for my $tag (sort $profile->known_tags) { + my $info = $profile->get_taginfo($tag); + my $description = $info->description('html', ' '); + my ($count, $overrides) = (0, 0); + my $tmpl = 'tag-not-seen'; + my $shown_count = 0; + my $tag_list = $by_tag{$tag}; + my $tag_limit_total = 1024; + my $tag_limit_per_package = 3; + + if (exists $by_tag{$tag}) { + $tmpl = 'tag'; + $count = $tag_statistics{$tag}{'count'}; + $overrides = $tag_statistics{$tag}{'overrides'}; + $shown_count = $count + $overrides; + } + if ($shown_count > $tag_limit_total) { + my (@replacement_list, %seen); + for my $orig_info ( + sort { $a->{pkg_info}{package} cmp $b->{pkg_info}{package} } + @{$tag_list}) { + my $pkg_info = $orig_info->{pkg_info}; + my $key + = "$pkg_info->{package} $pkg_info->{type} $pkg_info->{version}"; + next if ++$seen{$key} > $tag_limit_per_package; + push(@replacement_list, $orig_info); + last if @replacement_list >= $tag_limit_total; + } + $tag_list = \@replacement_list; + $shown_count = scalar(@replacement_list); + } + + my %maint_data = ( + description => $description, + tag => $tag, + code => $info->code, + tags => $tag_list, + shown_count => $shown_count, + tag_limit_per_package => $tag_limit_per_package, + graphs => $GRAPHS, + graphs_days => $GRAPHS_RANGE_DAYS, + statistics => { + count => $count, + overrides => $overrides, + total => $count + $overrides, + }, + ); + output_template("tags/$tag.html", $templates{$tmpl}, \%maint_data); + } + + # Create the general tag indices. + %data = ( + tags => \%by_tag, + stats => \%tag_statistics, + profile => \$profile, + ); + output_template('tags.html', $templates{tags}, \%data); + output_template('tags-severity.html', $templates{'tags-severity'}, \%data); + output_template('tags-all.html', $templates{'tags-all'}, \%data); + + # Update the statistics file. + open(my $stats_fd, '>', $statistics_file); + print {$stats_fd} "last-updated: $timestamp\n"; + for my $attr (@attrs) { + print {$stats_fd} "$attr: $statistics{$attr}\n"; + } + print {$stats_fd} "lintian-version: $LINTIAN_VERSION\n"; + close($stats_fd); + + $archives = required_cfg_value('archives'); + for my $archive (sort(keys(%{$archives}))) { + my $architectures + = required_cfg_non_empty_list_value('archives', $archive, + 'architectures'); + my $components + = required_cfg_non_empty_list_value('archives', $archive, + 'components'); + my $distributions + = required_cfg_non_empty_list_value('archives', $archive, + 'distributions'); + my $path = required_cfg_value('archives', $archive, 'base-dir'); + my $trace_basename + = required_cfg_value('archives', $archive, 'tracefile'); + + # The path to the mirror timestamp. + my $trace_file= "${path}/project/trace/${trace_basename}"; + my $mirror_timestamp = path($trace_file)->slurp; + $mirror_timestamp =~ s/\n.*//s; + $mirror_timestamp + = safe_qx('date', '-u', '--rfc-822', '-d', $mirror_timestamp); + my %info = ( + 'name' => $archive, + 'architectures' => $architectures, + 'components' => $components, + 'distributions' => $distributions, + 'timestamp' => $mirror_timestamp, + ); + push(@archive_info, \%info); + } + + # Finally, we can start creating the index page. + %data = ( + delta => \%delta, + archives => \@archive_info, + previous => $old_statistics->{'last-updated'}, + graphs => $GRAPHS, + graphs_days => $GRAPHS_RANGE_DAYS, + ); + output_template('index.html', $templates{index}, \%data); + return; +} + +sub setup_output_dir { + my (%args) = @_; + my $output_dir = $args{'output_dir'}; + my $lintian_manual = $args{'lintian_manual'}; + my $lintian_api = $args{'lintian_api_docs'}; + my $resource_dirs = $args{'resource_dirs'} // []; + my $lintian_log_file = $args{'lintian_log_file'}; + + # Create output directories. + mkdir($output_dir, 0777); + mkdir("$output_dir/full", 0777); + mkdir("$output_dir/maintainer", 0777); + mkdir("$output_dir/tags", 0777); + symlink('.', "$output_dir/reports"); + copy_dir($lintian_manual, "$output_dir/manual"); + copy_dir($lintian_api, "$output_dir/library-api"); + + if ($lintian_log_file) { + my %opts = ( + 'in' => $lintian_log_file, + 'out' => "$output_dir/lintian.log.gz", + ); + run_cmd(\%opts, 'gzip', '-9nc'); + $RESOURCE_MANAGER->install_resource("$output_dir/lintian.log.gz"); + symlink($RESOURCE_MANAGER->resource_URL('lintian.log.gz'), + "$output_dir/lintian.log.gz"); + } + + for my $dir (@{$resource_dirs}) { + next if not -d $dir; + opendir(my $dirfd, $dir); + for my $resname (readdir($dirfd)) { + next if $resname eq '.' or $resname eq '..'; + $RESOURCE_MANAGER->install_resource("$dir/$resname", + { install_method => 'copy' }); + } + closedir($dirfd); + } + return; +} + +sub collect_statistics { + my ($profile, $state_cache, $statistics_file, $maintainers_ref, + $sources_ref, $qa_list_ref) + = @_; + my $old_statistics; + + # For each of this maintainer's packages, add statistical information + # about the number of each type of tag to the QA data and build the + # packages hash used for the package index. We only do this for the + # maintainer packages, not the uploader packages, to avoid + # double-counting. + for my $maintainer (@{$maintainers_ref}) { + for my $source (keys %{ $by_maint{$maintainer} }) { + my %count; + for my $version ( + sort versions_comparator + keys %{ $by_maint{$maintainer}{$source} }){ + my $tags = $by_maint{$maintainer}{$source}{$version}; + for my $tag (@{$tags}) { + $count{$tag->{code}}++; + } + if (@$tags) { + $sources_ref->{$source}{$version} + = $tags->[0]{pkg_info}{xref}; + } + } + $qa_list_ref->{$source} = \%count; + } + } + + for my $tag ($profile->known_tags) { + my ($count, $overrides) = (0, 0); + my %seen_tags; + next if (not exists($by_tag{$tag})); + foreach (@{$by_tag{$tag}}) { + if ($_->{code} ne 'O') { + $count++; + $seen_tags{$_->{pkg_info}{xref}}++; + } else { + $overrides++; + } + } + $tag_statistics{$tag}{'count'} = $count; + $tag_statistics{$tag}{'overrides'} = $overrides; + $tag_statistics{$tag}{'packages'} = scalar(keys(%seen_tags)); + } + + # Read in the old statistics file so that we can calculate deltas for + # all of our statistics. + + if (-f $statistics_file) { + ($old_statistics) = read_dpkg_control_lc($statistics_file); + } + $statistics{'groups-known'} = scalar(keys(%{$state_cache->{'groups'}})); + $statistics{'groups-backlog'} + = scalar(find_backlog($LINTIAN_VERSION,$state_cache)); + my $pkgs_w_errors = 0; + for my $group_data (values(%{$state_cache->{'groups'}})) { + $pkgs_w_errors++ + if exists($group_data->{'processing-errors'}) + and $group_data->{'processing-errors'}; + } + $statistics{'groups-with-errors'} = $pkgs_w_errors; + + for my $attr (@attrs) { + my $old = $old_statistics->{$attr} || 0; + $statistics{$attr} ||= 0; + $delta{$attr} + = sprintf('%d (%+d)', $statistics{$attr},$statistics{$attr} - $old); + } + + return $old_statistics; +} + +sub extract_name_and_email { + my ($maintainer) = @_; + my ($name, $email) = ($maintainer =~ /^(.*) <([^>]+)>/); + $name = 'Unknown Maintainer' unless $name; + $email = 'unknown' unless $email; + return ($name, $email); +} + +# Generate the package lists. These are huge, so we break them into four +# separate pages. +# +# FIXME: Does anyone actually use these pages? They're basically unreadable. +sub generate_package_index_packages { + my ($sources_ref) = @_; + + my %list = ( + '0-9, A-F' => [], + 'G-L' => [], + 'M-R' => [], + 'S-Z' => [], + ); + for my $package (sort(keys(%{$sources_ref}))) { + my $first = uc(substr($package, 0, 1)); + if ($first le 'F') { push(@{ $list{'0-9, A-F'} }, $package) } + elsif ($first le 'L') { push(@{ $list{'G-L'} }, $package) } + elsif ($first le 'R') { push(@{ $list{'M-R'} }, $package) } + else { push(@{ $list{'S-Z'} }, $package) } + } + my %data = (sources => $sources_ref); + my $i = 1; + for my $section (sort(keys(%list))) { + $data{section} = $section; + $data{list} = $list{$section}; + output_template("packages_$i.html", $templates{packages}, \%data); + $i++; + } + return; +} + +sub run_scour { + my ($input_file, $output_file) = @_; + run_cmd('scour', '-i',$input_file, '-o',$output_file, '-q', + '--enable-id-stripping', '--enable-comment-stripping', + '--shorten-ids', '--indent=none'); + return 1; +} + +sub update_history_and_make_graphs { + my ($attrs_ref, $statistics_ref, $tag_statistics_ref) = @_; + # Update history. + my %versions; + my $graph_dir = "$HTML_TMP_DIR/graphs"; + my $commonf = "$graph_dir/common.gpi"; + my $unix_time = time(); + mkdir("$HISTORY_DIR") + if (not -d "$HISTORY_DIR"); + mkdir("$HISTORY_DIR/tags") + if (not -d "$HISTORY_DIR/tags"); + + my $history_file = "$HISTORY_DIR/statistics.dat"; + my $stats = ''; + for my $attr (@{$attrs_ref}) { + $stats .= ' ' . $statistics_ref->{$attr}; + } + open(my $hist_fd, '+>>', $history_file); + print {$hist_fd} "$unix_time $LINTIAN_VERSION$stats\n"; + + if ($GRAPHS) { + seek($hist_fd, 0, SEEK_SET); + while (<$hist_fd>) { + my @fields = split(); + $versions{$fields[1]} = $fields[0] + if not exists $versions{$fields[1]}; + } + } + close($hist_fd); + + if ($GRAPHS) { + mkdir("$graph_dir", 0777); + mkdir("$graph_dir/tags", 0777); + + my $date_min + = strftime('%s', + localtime($unix_time - 3600 * 24 * $GRAPHS_RANGE_DAYS)); + my $date_max = strftime('%s', localtime($unix_time)); + + # Generate loadable Gnuplot file with common variables and labels/arrows + # for Lintian versions. + open(my $common, '>', $commonf); + print {$common} "history_dir='$HISTORY_DIR'\n"; + print {$common} "graph_dir='$graph_dir'\n"; + print {$common} "date_min='$date_min'\n"; + print {$common} "date_max='$date_max'\n"; + my $last_version = 0; + for my $v (sort { $versions{$a} <=> $versions{$b} } keys %versions) { + next unless $versions{$v} > $date_min; + + print {$common} "set arrow from '$versions{$v}',graph 0 to ", + "'$versions{$v}',graph 1 nohead lw 0.4\n"; + + # Skip label if previous release is too close; graphs can't display + # more than ~32 labels. + my $min_spacing = 3600 * 24 * $GRAPHS_RANGE_DAYS / 32; + if ($versions{$v} - $last_version > $min_spacing) { + (my $label = $v) =~ s/\-[\w\d]+$//; + print {$common} "set label '$label' at '$versions{$v}',graph ", + "1.04 rotate by 90 font ',8'\n"; + + $last_version = $versions{$v}; + } + } + close($common); + + print "Plotting global statistics...\n"; + run_cmd({ 'chdir' => $graph_dir}, + 'gnuplot',"$LINTIAN_BASE/reporting/graphs/statistics.gpi"); + + if ($SCOUR_ENABLED) { + # Do a little "rename" dance to ensure that we keep the + # "statistics.svg"-basename without having to use a + # subdirectory. + rename( + "${graph_dir}/statistics.svg", + "${graph_dir}/_statistics-orig.svg" + ); + run_scour( + "${graph_dir}/_statistics-orig.svg", + "${graph_dir}/statistics.svg" + ); + } + $RESOURCE_MANAGER->install_resource("${graph_dir}/statistics.svg"); + } + + my $gnuplot_fd; + if ($GRAPHS) { + open($gnuplot_fd, '>', "$graph_dir/call.gpi"); + } + + for my $tag (sort(keys(%{$tag_statistics_ref}))) { + $history_file = "$HISTORY_DIR/tags/$tag.dat"; + $stats = $tag_statistics_ref->{$tag}; + open(my $tag_fd, '>>', $history_file); + print {$tag_fd} "$unix_time $stats->{'count'} $stats->{'overrides'} " + ."$stats->{'packages'}\n"; + close($tag_fd); + if ($GRAPHS) { + print {$gnuplot_fd} qq{print 'Plotting $tag statistics...'\n}; + print {$gnuplot_fd} + qq{call '$LINTIAN_BASE/reporting/graphs/tags.gpi' '$tag'\n}; + print {$gnuplot_fd} qq{reset\n}; + } + } + + if ($GRAPHS) { + my $svg_dir = "${graph_dir}/tags"; + close($gnuplot_fd); + run_cmd({'chdir' => $graph_dir}, 'gnuplot', 'call.gpi'); + unlink($commonf); + if ($SCOUR_ENABLED) { + # Obvious optimization potential; run scour in parallel + my $optimized_dir = "${graph_dir}/tags-optimized"; + mkdir($optimized_dir); + print "Minimizing tag graphs; this may take a while ...\n"; + for my $tag (sort(keys(%{$tag_statistics_ref}))) { + run_scour("${svg_dir}/${tag}.svg", + "${optimized_dir}/${tag}.svg"); + } + $svg_dir = $optimized_dir; + } + for my $tag (sort(keys(%{$tag_statistics_ref}))) { + my $graph_file = "${svg_dir}/${tag}.svg"; + $RESOURCE_MANAGER->install_resource($graph_file); + } + path($graph_dir)->remove_tree + if -d $graph_dir; + } + return; +} + +# Write out the QA package list. This is a space-delimited file that contains +# the package name and then the error count, warning count, info count, +# pedantic count, experimental count, and overridden tag count. +sub write_qa_list { + my ($qa_data) = @_; + + open(my $qa_fd, '>', "$HTML_TMP_DIR/qa-list.txt"); + for my $source (sort(keys(%{$qa_data}))) { + print {$qa_fd} $source; + for my $code (qw/E W I P X O/) { + my $count = $qa_data->{$source}{$code} || 0; + print {$qa_fd} " $count"; + } + print {$qa_fd} "\n"; + } + close($qa_fd); + return; +} + +# Generate a "redirect" lookup table for the webserver to power the +# "<site>/source/<source>[/<version>]" redirects. +sub generate_lookup_tables { + my ($sources_ref) = @_; + mkdir("$HTML_TMP_DIR/lookup-tables"); + open(my $table, '>', "$HTML_TMP_DIR/lookup-tables/source-packages"); + + foreach my $source (sort(keys(%{$sources_ref}))) { + my $first = 1; + for my $version ( + sort versions_comparator keys %{ $sources_ref->{$source} }) { + my $xref = $sources_ref->{$source}{$version}; + print {$table} "$source full/$xref\n" if $first; + print {$table} "$source/$version full/$xref\n"; + $first = 0; + } + } + + close($table); + return; +} + +# Determine the file name for the maintainer page given a maintainer. It +# should be <email>.html where <email> is their email address with all +# characters other than a-z A-Z 0-9 - _ . @ = + replaced with _. Don't change +# this without coordinating with QA. +sub maintainer_url { + my ($maintainer) = @_; + if ($maintainer =~ m/<([^>]+)>/) { + my $id = $1; + $id =~ tr/a-zA-Z0-9_.@=+-/_/c; + return "$id.html"; + } else { + return 'unsorted.html'; + } +} + +sub parse_lintian_log { + my ($profile, $state_cache) = @_; + # We take a lintian log file on either standard input or as the + # first argument. This log file contains all the tags lintian + # found, plus N: tags with informational messages. Ignore all the + # N: tags and load everything else into the hashes we use for all + # web page generation. + # + # We keep track of a hash from maintainer page URLs to maintainer + # values so that we don't have two maintainers who map to the same + # page and overwrite each other's pages. If we find two + # maintainers who map to the same URL, just assume that the second + # maintainer is the same as the first (but warn about it). + # + # The "last_*" are optimizations to avoid computing the same + # things over and over again when a package have multiple tags. + my (%seen, $last_info, $last_maintainer, %unknown_member_id, $info, + $last_pi, %map_maint, %arch_map); + my %expanded_code = ( + E => 'errors', + W => 'warnings', + I => 'info', + X => 'experimental', + O => 'overridden', + P => 'pedantic', + C => 'classifications', + ); + while (<>) { + my @parts; + chomp; + @parts = split_tag($_); + next unless @parts; + my ($code, $package, $type, $version, $arch, $tag, $extra) = @parts; + $type = 'binary' unless (defined $type); + next + unless ($type eq 'source' || $type eq 'binary' || $type eq 'udeb'); + # Ignore unknown tags - happens if we removed a tag that is + # still present in the log file. + my $tag_info = $profile->get_taginfo($tag); + next + if not $tag_info + or $tag_info->effective_severity eq 'classification'; + + # Update statistics. + my $key = $expanded_code{$code}; + $statistics{$key}++; + unless ($seen{"$package $type"}) { + $statistics{"$type-packages"}++; + $seen{"$package $type"} = 1; + } + + # Determine the source package for this package and warn if + # there appears to be no source package in the archive. + # Determine the maintainer, version, and archive component. Work + # around a missing source package by pulling information from + # a binary package or udeb of the same name if there is any. + my ($source, $component, $source_version, $maintainer, $uploaders); + my $member_id + = "${type}:${package}/${version}" + . ($type ne 'source' ? "/$arch" : q{}); + my $state_data = $state_cache->{'members-to-groups'}{$member_id}; + next if exists($unknown_member_id{$member_id}); + if ($type eq 'source') { + $source = $package; + $source_version = $version; + if (not defined($state_data)) { + warn "Source package ${member_id} not found in state-cache!\n"; + $unknown_member_id{$member_id} = 1; + } + } elsif (defined($state_data)) { + my $src_member + = first { s/^source:// } keys(%{$state_data->{'members'}}); + if ($src_member) { + ($source, $source_version) = split(m{/}, $src_member, 2); + } + } elsif (not defined($state_data)) { + warn "Package ${member_id} not found in state-cache!\n"; + $unknown_member_id{$member_id} = 1; + } + $state_data //= {}; + $component = $state_data->{'mirror-metadata'}{'component'} ||= 'main'; + $maintainer = $state_data->{'mirror-metadata'}{'maintainer'} + ||= '(unknown)'; + $uploaders = $state_data->{'mirror-metadata'}{'uploaders'}; + $source ||= ''; + $version = 'unknown' + unless (defined($version) and length($version) > 0); + $source_version = $version + unless (defined($source_version) and length($source_version) > 0); + + # Sanitize, just out of paranoia. + $package =~ tr/a-zA-Z0-9.+-/_/c; + $source =~ tr/a-zA-Z0-9.+-/_/c; + $version =~ tr/a-zA-Z0-9.+:~-/_/c; + $source_version =~ tr/a-zA-Z0-9.+:~-/_/c; + + # Conditionally call html_quote if needed. On average, 11-13% of + # all tags (emitted on lintian.d.o) have no "extra". That would be + # tags like "no-upstream-changelog" (now removed) + if (defined($extra)) { + $extra = html_quote($extra); + } else { + $extra = ''; + } + + # Store binary architectures + my $arch_key = join(':', $package, $type, $version, $tag, $extra); + $arch_map{$arch_key}{$arch} = 1 + unless $arch eq 'all' or $arch eq 'source'; + + # Don't duplicate entries if they only differ on architecture + next if scalar(keys %{$arch_map{$arch_key}}) > 1; + + # Add the tag information to our hashes. Share the data + # between the hashes to save space (which means we can't later + # do destructive tricks with it). + if ( $last_info + && $last_pi->{type} eq $type + && $last_pi->{package} eq $package + && $last_pi->{version} eq $version) { + + # There are something like 622k tags emitted on lintian.d.o, + # but only "some" 90k unique package+version(+arch) pairs. + # Therefore, we can conclude that the average package will + # have ~6 tags and optimise for that case. Indeed, this path + # seems to be taken about 90% of the time (561k/624k). + # - In fact, we see less than "90k" package+version(+arch) + # pairs here, since entries without tags never this far down + # in this loop (i.e. they are filtered out by split_tag + # above). + + # Copy the last info and then change the bits that can change + $info = {%{$last_info}}; + # Code depends on whether the given tag was overridden or not + $info->{code} = $code; + $info->{extra} = $extra; + if ($info->{tag_info}->name ne $tag) { + $info->{tag_info} = $tag_info; + } + # saves a map_maintainer call + $maintainer = $last_maintainer; + } else { + + my $anchor = "${source}_${source_version}"; + # Apparently "+" are not allowed in ids and I am guessing + # ":" is not either + if (index($anchor, '+') > -1 or index($anchor, ':') > -1) { + $anchor =~ s/[+]/_x2b/g; + $anchor =~ s/[:]/_x3a/g; + } + if (substr($maintainer, 0, 1) eq q{"}) { + # Strip out ""-quotes, which is required in d/control for some + # maintainers. + $maintainer =~ s/^"(.*)" <(.*)>$/$1 <$2>/; + } + + # Check if we've seen the URL for this maintainer before + # and, if so, map them to the same person as the previous + # one. + + $last_maintainer = $maintainer + = map_maintainer(\%map_maint, $maintainer); + + # Update maintainer statistics. + $statistics{maintainers}++ unless defined $by_maint{$maintainer}; + + $last_info = $info = { + # Tag instance specific data + + # split_tags ensures that $code is a single upper case letter + code => $code, + tag_info => $tag_info, + # extra is unsafe in general, but we already quote it above. + extra => $extra, + archs => $arch_map{$arch_key}, + + # Shareable data + pkg_info => { + package => $package, + version => $version, + # There is a check for type being in a fixed whitelist of + # HTML-safe keywords in the start of the loop., + type => $type, + component => html_quote($component), + # should be safe + anchor => $anchor, + xref => maintainer_url($maintainer). "#${anchor}", + 'state_data' => $state_data, + maintainer => html_quote($maintainer), + }, + }; + $last_pi = $info->{pkg_info}; + if (!$by_maint{$maintainer}{$source}{$source_version}) { + my $list_ref = []; + $by_maint{$maintainer}{$source}{$source_version} = $list_ref; + # If the package had uploaders listed, also add the + # information to %by_uploaders (still sharing the data + # between hashes). + if ($uploaders) { + for my $uploader (@{$uploaders}) { + if (substr($uploader, 0, 1) eq q{"}) { + # Strip out ""-quotes, which is required in + # d/control for some uploaders. + $uploader =~ s/^"(.*)" <(.*)>$/$1 <$2>/; + } + $uploader = map_maintainer(\%map_maint, $uploader); + next if $uploader eq $maintainer; + $by_uploader{$uploader}{$source}{$source_version} + = $list_ref; + } + } + } + } + + push(@{ $by_maint{$maintainer}{$source}{$source_version} }, $info); + $by_tag{$tag} ||= []; + push(@{ $by_tag{$tag} }, $info); + + } + return; +} + +# Deduplicate maintainers. Maintains a cache of the maintainers we've seen +# with a given e-mail address and returns the maintainer string that we +# should use (which is whatever maintainer we saw first with that e-mail). +sub map_maintainer { + my ($urlmap, $maintainer) = @_; + my $url = maintainer_url($maintainer); + if (defined(my $res = $urlmap->{$url})) { + $maintainer = $res; + } else { + $urlmap->{$url} = $maintainer; + } + return $maintainer; +} + +# Quote special characters for HTML output. +sub html_quote { + my ($text) = @_; + $text ||= ''; + # Use index to do a quick check before we bother requesting a + # subst. On average, this is cheaper than blindly s///'ing, since + # we rarely subst (all) of the characters below. + if (index($text, '&') > -1) { + $text =~ s/&/\&/g; + } + if (index($text, '<') > -1) { + $text =~ s/</\</g; + } + if (index($text, '>') > -1) { + $text =~ s/>/\>/g; + } + if (index($text, '/') > -1) { + $text =~ s/\//\//g; + } + return $text; +} + +# Given a file name, a template, and a data hash, fill out the template with +# that data hash and output the results to the file. +sub output_template { + my ($file, $template, $data) = @_; + my $path_prefix = $data->{path_prefix}; + if (not defined($path_prefix)) { + $path_prefix = ''; + if (index($file, '/') > -1) { + $path_prefix = '../' x ($file =~ tr|/||); + } + } + $data->{version} ||= $LINTIAN_VERSION; + $data->{timestamp} ||= $timestamp; + $data->{by_version} ||= \&versions_comparator; + $data->{path_prefix} ||= $path_prefix; + $data->{html_quote} ||= \&html_quote; + $data->{resource_path} ||= sub { + return $path_prefix . $RESOURCE_MANAGER->resource_URL($_[0]); + }; + $data->{resource_integrity} ||= sub { + return $RESOURCE_MANAGER->resource_integrity_value($_[0]); + }; + $data->{head} ||= sub { + $templates{head}->fill_in( + HASH => { + page_title => $_[0], + config_vars => $TEMPLATE_CONFIG_VARS, + %{$data}, + }) or die "Filling out head of $file: $Text::Template::ERROR\n"; + }; + $data->{foot} ||= sub { + $templates{foot}->fill_in( + HASH => { + config_vars => $TEMPLATE_CONFIG_VARS, + %{$data}, + }) or die "Filling out footer of $file: $Text::Template::ERROR\n"; + }; + $data->{config_vars} ||= $TEMPLATE_CONFIG_VARS; + open(my $fd, '>:encoding(UTF-8)', "$HTML_TMP_DIR/$file"); + $template->fill_in(OUTPUT => $fd, HASH => $data) + or die "filling out $file failed: $Text::Template::ERROR\n"; + close($fd); + return; +} + +# Sort function for sorting lists of tags. Sort by package, version, component, +# type, tag, and then any extra data. This will produce the best HTML output. +# +# Note that source tags must come before all other tags, hence the "unfair" +# priority for those. This is because the first tags listed are assumed to +# be source package tags. +sub by_tag { + my $a_pi = $a->{pkg_info}; + my $b_pi = $b->{pkg_info}; + if ($a_pi->{type} ne $b_pi->{type}) { + return -1 if $a_pi->{type} eq 'source'; + return 1 if $b_pi->{type} eq 'source'; + } + return + $a_pi->{package} cmp $b_pi->{package} + || $a_pi->{version} cmp $b_pi->{version} + || $a_pi->{component} cmp $b_pi->{component} + || $a_pi->{type} cmp $b_pi->{type} + || $a->{tag_info}->name cmp $b->{tag_info}->name + || $a->{extra} cmp $b->{extra}; +} + +=item split_tag + +=cut + +{ + # Matches something like: (1:2.0-3) [arch1 arch2] + # - captures the version and the architectures + my $verarchre = qr,(?: \s* \(( [^)]++ )\) \s* \[ ( [^]]++ ) \]),xo; + # ^^^^^^^^ ^^^^^^^^^^^^ + # ( version ) [architecture ] + + # matches the full deal: + # 1 222 3333 4444444 5555 666 777 + # - T: pkg type (version) [arch]: tag [...] + # ^^^^^^^^^^^^^^^^^^^^^ + # Where the marked part(s) are optional values. The numbers above + # the example are the capture groups. + my $TAG_REGEX + = qr/([EWIXOPC]): (\S+)(?: (\S+)(?:$verarchre)?)?: (\S+)(?:\s+(.*))?/; + + sub split_tag { + my ($tag_input) = @_; + my $pkg_type; + return unless $tag_input =~ /^${TAG_REGEX}$/; + # default value... + $pkg_type = $3//'binary'; + return ($1, $2, $pkg_type, $4, $5, $6, $7); + } +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/commands/reporting-lintian-harness.pm b/commands/reporting-lintian-harness.pm new file mode 100644 index 0000000..afca58d --- /dev/null +++ b/commands/reporting-lintian-harness.pm @@ -0,0 +1,603 @@ +#!/usr/bin/perl -w + +# Lintian reporting harness -- Run lintian against an archive mirror +# +# Copyright (C) 2015 Niels Thykier +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# +# Based on "reporting/harness", which was: +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# +# This program is free software. It is distributed under the terms of +# the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package reporting_lintian_harness; + +use v5.20; +use warnings; +use utf8; +use autodie; + +use constant BACKLOG_PROCESSING_TIME_LIMIT => 4 * 3600; # 4hours + +use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC SEEK_END); +use File::Basename qw(basename); +use File::Temp qw(tempfile); +use Getopt::Long(); +use IO::Async::Loop; +use IO::Async::Process; +use List::MoreUtils qw(first_index); +use POSIX qw(strftime); + +use Lintian::IO::Async qw(safe_qx); +use Lintian::Reporting::Util + qw(find_backlog load_state_cache save_state_cache); + +use constant EMPTY => q{}; +use constant COLON => q{:}; +use constant NEWLINE => qq{\n}; + +my (@LINTIAN_CMD, $LINTIAN_VERSION); + +my @REQUIRED_PARAMETERS = qw( + lintian-log-dir + schedule-chunk-size + schedule-limit-groups + state-dir +); +my %OPT = ('lintian-frontend' => 'lintian',); +my %OPT_HASH = ( + 'schedule-chunk-size=i' => \$OPT{'schedule-chunk-size'}, + 'schedule-limit-groups=i' => \$OPT{'schedule-limit-groups'}, + 'state-dir=s' => \$OPT{'state-dir'}, + 'lintian-frontend=s' => \$OPT{'lintian-frontend'}, + 'lintian-log-dir=s' => \$OPT{'lintian-log-dir'}, + 'lintian-scratch-space=s' => \$OPT{'lintian-scratch-space'}, + 'help|h' => \&usage, +); + +sub main { + STDOUT->autoflush; + Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev'); + Getopt::Long::GetOptions(%OPT_HASH) or die("error parsing options\n"); + check_parameters(); + $LINTIAN_VERSION= safe_qx($OPT{'lintian-frontend'}, '--print-version'); + chomp($LINTIAN_VERSION); + prepare_lintian_environment_and_cmdline(); + exit(harness_lintian()); +} + +### END OF SCRIPT -- below are helper subroutines ### + +=item untaint(VALUE) + +Untaint VALUE + +=cut + +sub untaint { + return $_[0] = $1 if $_[0] =~ m/^(.*)$/; + return; +} + +sub check_parameters { + for my $parameter (@REQUIRED_PARAMETERS) { + if (not defined($OPT{$parameter})) { + die( "Missing required parameter \"--${parameter}\"" + . "(use --help for more info)\n"); + } + } + if (-d $OPT{'state-dir'}) { + untaint($OPT{'state-dir'}); + } else { + die("The --state-dir parameter must point to an existing directory\n"); + } + die("The argument for --schedule-limit-groups must be an > 0\n") + if $OPT{'schedule-limit-groups'} < 1; + + return; +} + +sub prepare_lintian_environment_and_cmdline { + my $frontend = 'lintian'; + my $eoa_marker_index = first_index { $_ eq '--' } @ARGV; + my $logs_dir = $OPT{'lintian-log-dir'}; + my @overridable_args = (qw(-EL +>=classification --show-overrides)); + my @args = ( + qw(--verbose), # We rely on this for filtering the log + qw(--exp-output=format=fullewi --packages-from-file -), + qw(--perf-debug --perf-output), + "+${logs_dir}/lintian-perf.log", + ); + $frontend = $OPT{'lintian-frontend'} if ($OPT{'lintian-frontend'}); + + if ($eoa_marker_index > -1) { + # Move known "non-parameters" and the "--" behind our arguments. + # It is a misfeature, but at least it does not break + # our code. NB: It requires *two* "--" on the command-line to + # trigger this case. + push(@args, splice(@ARGV, $eoa_marker_index)); + } + # Put "our" arguments after user supplied ones + @LINTIAN_CMD = ($frontend, @overridable_args, @ARGV, @args); + + # The environment part + for my $key (keys(%ENV)) { + delete($ENV{$key}) if $key =~ m/^LINTIAN_/; + } + if ($OPT{'lintian-scratch-space'}) { + $ENV{'TMPDIR'} = $OPT{'lintian-scratch-space'}; + log_msg("Setting TMPDIR to $ENV{'TMPDIR'}"); + } else { + log_msg('Leaving TMPDIR unset (no --lintian-scratch-space'); + } + return; +} + +sub log_msg { + my ($msg) = @_; + my $ts = strftime('[%FT%T]: ', localtime()); + print $ts, $msg, "\n"; + return; +} + +sub harness_lintian { + my (@worklist); + my $exit_code = 0; + my $state = load_state_cache($OPT{'state-dir'}); + my $lintian_log_dir = $OPT{'lintian-log-dir'}; + my $lintian_log = "${lintian_log_dir}/lintian.log"; + log_msg('Update complete, loading current state information'); + + @worklist = find_backlog($LINTIAN_VERSION, $state); + + # Always update the log if it exists, as we may have removed + # some entries. + if (-f $lintian_log) { + my $filter = generate_log_filter($state, {}); + + # update lintian.log + log_msg('Updating lintian.log...'); + rewrite_lintian_log($filter); + } + + log_msg(''); + + if (not @worklist) { + log_msg('Skipping Lintian run - nothing to do...'); + } else { + log_msg('Processing backlog...'); + if (@worklist > $OPT{'schedule-limit-groups'}) { + log_msg( + "Truncating worklist to size $OPT{'schedule-limit-groups'}" + . ' from ' + . (scalar(@worklist))); + @worklist = splice(@worklist, 0, $OPT{'schedule-limit-groups'}); + } + $exit_code= process_worklist(\@worklist, $state, $lintian_log_dir); + } + return $exit_code; +} + +sub process_worklist { + my ($worklist_ref, $state, $lintian_log_dir) = @_; + my $round = 0; + my $rounds = 1; + my @worklist = @{$worklist_ref}; + my $exit_code = 0; + my $schedule_chunk_size = $OPT{'schedule-chunk-size'}; + my $start_time = time(); + + if ($schedule_chunk_size > 0) { + # compute the number of rounds needed. + my $size_up = scalar @worklist + ($schedule_chunk_size - 1); + $rounds = int($size_up / $schedule_chunk_size); + } + + log_msg( + sprintf( + 'Groups to process %d will take %d round(s) [round limit: %s]', + scalar @worklist, + $rounds,$schedule_chunk_size > 0 ? $schedule_chunk_size : 'none' + )); + + log_msg('Command line used: ' . join(q{ }, @LINTIAN_CMD)); + while (@worklist) { + my $len = scalar @worklist; + my (@work_splice, @completed, %processed, %errors); + my ($status_fd, $lint_status_out); + my $got_alarm = 0; + + # Bail if there is less than 5 minutes left + if (time() >= $start_time + BACKLOG_PROCESSING_TIME_LIMIT - 300) { + log_msg('No more time for processing backlogs'); + $exit_code = 2; + last; + } + + $round++; + # correct bounds to fit chunk size + if ($schedule_chunk_size > 0 and $len > $schedule_chunk_size) { + $len = $schedule_chunk_size; + } + + # Sort @work_splice to have the "Range:"-line below produce + # reasonable output. + @work_splice = sort(splice(@worklist, 0, $len)); + + log_msg("Running Lintian (round $round/$rounds) ..."); + if ($len == 1) { + log_msg(' - Single group: ' . $work_splice[0]); + } else { + log_msg(' - Range: GROUP:' + . $work_splice[0] + . q{ ... GROUP:} + . $work_splice[-1]); + } + + next if ($OPT{'dry-run'}); + + pipe($status_fd, $lint_status_out); + my ($nfd, $new_lintian_log) + = tempfile('lintian.log-XXXXXXX', DIR => $lintian_log_dir); + # We do not mind if anyone reads the lintian log as it is being written + chmod(0644, $nfd); + log_msg("New lintian log at $new_lintian_log"); + + my $loop = IO::Async::Loop->new; + my $future = $loop->new_future; + my $signalled_lintian = 0; + + push(@LINTIAN_CMD, '--status-log', '&3'); + my $process = IO::Async::Process->new( + command => [@LINTIAN_CMD], + stdin => { via => 'pipe_write' }, + stdout => { via => 'pipe_read' }, + stderr => { via => 'pipe_read' }, + fd3 => { via => 'pipe_read' }, + on_finish => sub { + my ($self, $exitcode) = @_; + my $status = ($exitcode >> 8); + my $signal = ($exitcode & 0xff); + + if ($signal) { + log_msg("Lintian terminated by signal: $signal"); + # If someone is sending us signals (e.g. SIGINT/Ctrl-C) + # don't start the next round. + log_msg(' - skipping the rest of the worklist'); + @worklist = (); + $future->fail( + "Command @LINTIAN_CMD received signal $signal"); + return; + } + + if ($status == 0 || $status == 1) { + # exit 1 (policy violations) happens all the time (sadly) + # exit 2 (broken packages) also happens all the time... + log_msg('Lintian finished successfully'); + $future->done("Done with @LINTIAN_CMD"); + return; + } + + log_msg("warning: executing lintian returned status $status"); + if ($got_alarm) { + # Ideally, lintian would always die by the signal + # but some times it catches it and terminates + # "normally" + log_msg('Stopped by a signal or time out'); + log_msg(' - skipping the rest of the worklist'); + @worklist = (); + } + + $future->fail("Error status $status from @LINTIAN_CMD"); + return; + }); + + $process->stdout->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + if (length $$buffref) { + print {$nfd} $$buffref; + $$buffref = EMPTY; + } + + close($nfd) + if $eof; + + return 0; + }, + ); + + $process->stderr->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + if (length $$buffref) { + print STDOUT $$buffref; + $$buffref = EMPTY; + } + + return 0; + }, + ); + + $process->fd3->configure( + on_read => sub { + my ($stream, $buffref, $eof) = @_; + + while($$buffref =~ s/^(.*)\n//) { + my $line = $1; + + # listen to status updates from lintian + if ($line =~ m/^complete ([^ ]+) \(([^\)]+)\)$/) { + my ($group_id, $runtime) = ($1, $2); + push(@completed, $group_id); + $processed{$group_id} = 1; + log_msg(" [lintian] processed $group_id" + . " successfully (time: $runtime)"); + } elsif ($line =~ m/^error ([^ ]+) \(([^\)]+)\)$/) { + my ($group_id, $runtime) = ($1, $2); + log_msg(" [lintian] error processing $group_id " + . "(time: $runtime)"); + $processed{$group_id} = 1; + # We ignore errors if we sent lintian a signal to avoid + # *some* false-positives. + $errors{$group_id} = 1 if not $signalled_lintian; + } elsif ($line =~ m/^ack-signal (SIG\S+)$/) { + my $signal = $1; + log_msg( +"Signal $signal acknowledged: disabled timed alarms" + ); + alarm(0); + } + } + + alarm(0) + if $eof; + + return 0; + }, + ); + + $loop->add($process); + + my $groups = $state->{'groups'}; + # Submit the tasks to Lintian + foreach my $group_id (@work_splice) { + my $members; + if (not exists($groups->{$group_id})) { + # Sanity check (can in theory happen if an external process + # modifies the state cache and we have reloaded it) + log_msg( + "Group ${group_id} disappeared before we could schedule it" + ); + next; + } + $members = $groups->{$group_id}{'members'}; + for my $member_id (sort(keys(%{${members}}))) { + my $path = $members->{$member_id}{'path'}; + $process->stdin->write($path . NEWLINE); + } + } + $process->stdin->close_when_empty; + + eval { + my $time_limit + = $start_time + BACKLOG_PROCESSING_TIME_LIMIT - time(); + my $count = 0; + my $sig_handler = sub { + my ($signal_name) = @_; + $signalled_lintian = 1; + $count++; + if ($signal_name eq 'ALRM') { + $got_alarm = 1 if $got_alarm >= 0; + } else { + $got_alarm = -1; + } + if ($count < 3) { + my $pid = $process->pid; + log_msg("Received SIG${signal_name}, " + . "sending SIGTERM to $pid [${count}/3]"); + $process->kill('TERM'); + if ($signal_name eq 'ALRM') { + log_msg( + 'Scheduling another alarm in 5 minutes from now...' + ); + alarm(300); + } + } else { + my $pid = $process->pid; + log_msg("Received SIG${signal_name} as the third one, " + . "sending SIGKILL to $pid"); + log_msg('You may have to clean up some ' + . 'temporary directories manually'); + $process->kill('KILL'); + } + }; + local $SIG{'TERM'} = $sig_handler; + local $SIG{'INT'} = $sig_handler; + local $SIG{'ALRM'} = $sig_handler; + + alarm($time_limit); + }; + + # Wait for lintian to terminate + $future->await; + + if ($got_alarm) { + if ($got_alarm == 1) { + # Lintian was (presumably) killed due to a + # time-out from this process + $exit_code = 2; + } else { + # Lintian was killed by another signal; notify + # harness that it should skip the rest as well. + $exit_code = 3; + } + } + + log_msg('Updating the lintian log used for reporting'); + my $filter = generate_log_filter($state, \%processed); + seek($nfd, 0, SEEK_END); + update_lintian_log($filter, $nfd, $new_lintian_log); + + log_msg('Updating harness state cache'); + # Reload the state cache, just in case it was modified by an external + # process during the lintian run. + $state = load_state_cache($OPT{'state-dir'}); + for my $group_id (@completed) { + my $group_data; + # In theory, they can disappear - in practise, that requires + # an external call to (e.g.) lintian reporting-sync-state. + next if not exists($state->{'groups'}{$group_id}); + $group_data = $state->{'groups'}{$group_id}; + $group_data->{'last-processed-by'} = $LINTIAN_VERSION; + delete($group_data->{'out-of-date'}); + # Always clear the error counter after a successful run. + delete($group_data->{'processing-errors'}); + delete($group_data->{'last-error-by'}); + } + for my $group_id (sort(keys(%errors))) { + my $group_data; + # In theory, they can disappear - in practise, that requires + # an external call to (e.g.) lintian reporting-sync-state. + next if not exists($state->{'groups'}{$group_id}); + $group_data = $state->{'groups'}{$group_id}; + if ($errors{$group_id}) { + if (not exists($group_data->{'last-error-by'}) + or $group_data->{'last-error-by'} ne $LINTIAN_VERSION) { + # If it is a new lintian version then (re)set the counter + # to 1. Case also triggers for the very first issue. + $group_data->{'processing-errors'} = 1; + } else { + # Repeated error with the same version + ++$group_data->{'processing-errors'}; + } + # Set the "last-error-by" flag so we can clear the + # error if there is a new version of lintian. + $group_data->{'last-error-by'} = $LINTIAN_VERSION; + } else { + delete($group_data->{'processing-errors'}); + } + } + save_state_cache($OPT{'state-dir'}, $state); + last if $exit_code; + } + return $exit_code; +} + +sub generate_log_filter { + my ($state, $exclude) = @_; + my %filter; + my $group_map = $state->{'groups'}; + for my $group_id (keys(%{${group_map}})) { + my $members; + next if exists($exclude->{$group_id}); + $members = $group_map->{$group_id}{'members'}; + for my $member_id (keys(%{$members})) { + $filter{$member_id} = 1; + } + } + return \%filter; +} + +sub update_lintian_log { + my ($keep_filter, $new_fd, $tmp_path) = @_; + my $lintian_log_dir = $OPT{'lintian-log-dir'}; + my $lintian_log = "${lintian_log_dir}/lintian.log"; + my $copy_mode = 0; + my $first = 1; + + eval { + open(my $input, '<', $lintian_log); + while (<$input>) { + if ( + m/^N: [ ] Processing [ ] (binary|udeb|source) [ ] + package [ ] (\S+) [ ] \(version [ ] (\S+), [ ] + arch [ ] (\S+)\)[ ]\.\.\./xsm + ) { + my ($type, $pkg, $ver, $arch) = ($1,$2, $3, $4); + my $k = "$type:$pkg/$ver"; + $k .= "/$arch" if $type ne 'source'; + $copy_mode = 0; + $copy_mode = 1 if exists($keep_filter->{$k}); + } + if ($copy_mode) { + if ($first) { + print {$new_fd} "N: ---start-of-old-lintian-log-file---\n"; + $first = 0; + } + print {$new_fd} $_; + } + } + close($input); + close($new_fd); + rename($tmp_path, $lintian_log); + }; + if (my $err = $@) { + # Unlink $new_lintian_log, we ignore errors as the one we + # already got is more important/interesting. + no autodie qw(unlink); + unlink($tmp_path) or warn("Cannot unlink $tmp_path: $!"); + die($err); + } + return; +} + +sub rewrite_lintian_log { + my ($keep_filter) = @_; + my $lintian_log_dir = $OPT{'lintian-log-dir'}; + my ($nfd, $new_lintian_log); + + ($nfd, $new_lintian_log) + = tempfile('lintian.log-XXXXXXX', DIR => $lintian_log_dir); + chmod(0644, $nfd); + update_lintian_log($keep_filter, $nfd, $new_lintian_log); + return 1; +} + +sub usage { + my $cmd = basename($0); + my $me = "lintian $cmd"; + print <<EOF; +Internal command for the Lintian reporting framework +Usage: $me <args> -- <extra lintian args> + + --help Show this text and exit + + --lintian-frontend PROG Use PROG as frontend for lintian (defaults to "lintian") + --lintian-log-dir DIR Path to the harness log dir. [!] + --lintian-scratch-space DIR Use DIR for temporary files (notably temp labs) + --schedule-chunk-size N Run at most N groups in a given lintian run. + --schedule-limit-groups N Schedule at most N groups in total. [!] + --state-dir DIR Directory containing the state cache (must be + writable). [!] + +Arguments marked with [!] are required for a successful run. +EOF + + exit(0); +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et + diff --git a/commands/reporting-sync-state.pm b/commands/reporting-sync-state.pm new file mode 100644 index 0000000..af649a7 --- /dev/null +++ b/commands/reporting-sync-state.pm @@ -0,0 +1,572 @@ +#!/usr/bin/perl -w +# +# reporting-sync-state +# +# Copyright (C) 2018 Chris Lamb <lamby@debian.org> +# +# This program is free software. It is distributed under the terms of +# the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package reporting_sync_state; + +use v5.20; +use warnings; +use utf8; +use autodie; + +use Getopt::Long(); +use File::Basename qw(basename); +use YAML::XS (); +use MIME::Base64 qw(encode_base64); + +use Lintian::Deb822::Parser qw(visit_dpkg_paragraph_string); +use Lintian::Relation::Version qw(versions_comparator); +use Lintian::Reporting::Util qw( + find_backlog + load_state_cache + save_state_cache +); +use Lintian::Util qw( + open_gz +); + +my $DEFAULT_CHECKSUM = 'Sha256'; +my (%KNOWN_MEMBERS, %ACTIVE_GROUPS); +my $CONFIG; +my %OPT; +my %OPT_HASH= ( + 'reporting-config=s'=> \$OPT{'reporting-config'}, + 'desired-version=s' => \$OPT{'desired-version'}, + 'reschedule-all' => \$OPT{'reschedule-all'}, + 'help|h' => \&usage, + 'debug|d' => \$OPT{'debug'}, + 'dry-run' => \$OPT{'dry-run'}, +); + +sub check_parameters { + for my $parameter (qw(reporting-config desired-version)) { + if (not defined($OPT{$parameter})) { + die( "Missing required parameter \"--${parameter}\"" + . "(use --help for more info)\n"); + } + } + if (not $OPT{'reporting-config'} or not -f $OPT{'reporting-config'}) { + die("The --reporting-config parameter must point to an existing file\n" + ); + } + return; +} + +sub required_cfg_value { + my (@keys) = @_; + my $v = $CONFIG; + for my $key (@keys) { + if (not exists($v->{$key})) { + my $k = join('.', @keys); + die("Missing required config parameter: ${k}\n"); + } + $v = $v->{$key}; + } + return $v; +} + +sub required_cfg_non_empty_list_value { + my (@keys) = @_; + my $v = required_cfg_value(@keys); + if (not defined($v) or ref($v) ne 'ARRAY' or scalar(@{$v}) < 1) { + my $k = join('.', @keys); + die("Invalid configuration: ${k} must be a non-empty list\n"); + } + return $v; +} + +sub optional_cfg_list_value { + my (@keys) = @_; + my $v = $CONFIG; + for my $key (@keys) { + if (not exists($v->{$key})) { + return []; + } + $v = $v->{$key}; + } + if (ref($v) ne 'ARRAY') { + my $k = join('.', @keys); + die("Invalid configuration: ${k} must be a list (or missing)\n"); + } + return $v; +} + +sub main { + my ($state_dir, $state, $archives, %blacklist); + STDOUT->autoflush; + Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev'); + Getopt::Long::GetOptions(%OPT_HASH) or die("error parsing options\n"); + check_parameters(); + $CONFIG = YAML::XS::LoadFile($OPT{'reporting-config'}); + $state_dir = required_cfg_value('storage', 'state-cache'); + $state = load_state_cache($state_dir); + + if (upgrade_state_cache_if_needed($state)) { + log_debug('Updated the state cache'); + } + log_debug('Initial state had ' + . (scalar(keys(%{$state->{'groups'}}))) + . ' groups'); + $archives = required_cfg_value('archives'); + %blacklist = map { $_ => 1 } @{optional_cfg_list_value('blacklist')}; + for my $archive (sort(keys(%{$archives}))) { + log_debug("Processing archive $archive"); + my $path = required_cfg_value('archives', $archive, 'base-dir'); + my $archs = required_cfg_non_empty_list_value('archives', $archive, + 'architectures'); + my $components + = required_cfg_non_empty_list_value('archives', $archive, + 'components'); + my $distributions + = required_cfg_non_empty_list_value('archives', $archive, + 'distributions'); + local_mirror_manifests($state, $path, $distributions, $components, + $archs, \%blacklist); + } + + cleanup_state($state); + if (not $OPT{'dry-run'}) { + save_state_cache($state_dir, $state); + } + exit(0); +} + +# State: +# group-id => { +# 'last-processed-by' => <version or undef>, +# 'out-of-date' => <0|1>, (# if omitted => 0, unless "last-processed-by" is omitted as well) +# 'members' => { +# $member_id => { +# 'sha1' => <sha1>, +# 'path' => <path/relative/to/mirror>, +# } +# }, + +sub upgrade_state_cache_if_needed { + my ($state) = @_; + if (exists($state->{'groups'})) { + my $updated = 0; + my $groups = $state->{'groups'}; + for my $group (sort(keys(%{$groups}))) { + my $group_data = $groups->{$group}; + if ( exists($group_data->{'mirror-metadata'}) + && exists($group_data->{'mirror-metadata'}{'area'})) { + if (not exists($group_data->{'mirror-metadata'}{'component'})){ + $group_data->{'mirror-metadata'}{'component'} + = $group_data->{'mirror-metadata'}{'area'}; + delete($group_data->{'mirror-metadata'}{'area'}); + $updated = 1; + } + } + } + return $updated; + } + # Migrate the "last-processed-by" version. + my $groups = $state->{'groups'} = {}; + for my $key (sort(keys(%${state}))) { + next if $key eq 'group'; + if (exists($state->{$key}{'last-processed-by'})) { + my $last_version = $state->{$key}{'last-processed-by'}; + delete($state->{$key}); + $groups->{$key}{'last-processed-by'} = $last_version; + } + } + return 1; +} + +sub add_member_to_group { + my ($state, $group_id, $member_id, $member_data, $group_metadata) = @_; + # Fetch members before group_data (relying on autovivification) + my $members = $state->{'groups'}{$group_id}{'members'}; + my $group_data = $state->{'groups'}{$group_id}; + my $member; + my $new_group = 0; + if (not defined($members)) { + $group_data->{'members'} = $members = {}; + log_debug( + "${group_id} is out-of-date: New group (triggered by ${member_id})" + ); + $new_group = 1; + } + + $member = $members->{$member_id}; + if (not defined($member)) { + $members->{$member_id} = $member = {}; + } + + # Update of path is not sufficient to consider the member out of date + # (mirror restructuring happens - although extremely rarely) + $member->{'path'} = $member_data->{'path'}; + if ($member_data->{'mirror-metadata'} + && keys(%{$member_data->{'mirror-metadata'}})) { + $member->{'mirror-metadata'} = $member_data->{'mirror-metadata'}; + } + if (not exists($group_data->{'mirror-metadata'})) { + $group_data->{'mirror-metadata'}= $group_metadata->{'mirror-metadata'}; + } else { + for my $key (keys(%{$group_metadata->{'mirror-metadata'}})) { + $group_data->{'mirror-metadata'}{$key} + = $group_metadata->{'mirror-metadata'}{$key}; + } + } + $KNOWN_MEMBERS{"${group_id} ${member_id}"} = 1; + $ACTIVE_GROUPS{$group_id} = 1; + + if (!exists($member->{lc $DEFAULT_CHECKSUM}) + || $member->{lc $DEFAULT_CHECKSUM} ne + $member_data->{lc $DEFAULT_CHECKSUM}) { + if (exists($member->{lc $DEFAULT_CHECKSUM})) { + # This seems worth a note even if the group is already out of date + my $lowercase = lc $DEFAULT_CHECKSUM; + log_debug( + "${group_id} is out-of-date: ${member_id} checksum mismatch" + . " ($member->{$lowercase} != $member_data->{$lowercase})"); + } elsif (not $group_data->{'out-of-date'} and not $new_group) { + log_debug("${group_id} is out-of-date: New member (${member_id})"); + } + $group_data->{'out-of-date'} = 1; + $member->{lc $DEFAULT_CHECKSUM} = $member_data->{lc $DEFAULT_CHECKSUM}; + } + delete($member->{'sha1'}); + + return; +} + +sub cleanup_state { + my ($state) = @_; + my %backlog + = map { $_ => 1 } find_backlog($OPT{'desired-version'}, $state); + + # Empty 'members-to-groups' to prune "dead links". It will be + # recreated by cleanup_group_state below. + $state->{'members-to-groups'} = {}; + + for my $group_id (sort(keys(%{$state->{'groups'}}))) { + cleanup_group_state($state, $group_id, \%backlog); + } + return; +} + +sub remove_if_empty { + my ($hash_ref, $key) = @_; + my ($val, $empty); + return if not exists($hash_ref->{$key}); + $val = $hash_ref->{$key}; + if (defined($val)) { + $empty = 1 if (ref($val) eq 'HASH' and not keys(%${val})); + $empty = 1 if (ref($val) eq 'ARRAY' and not scalar(@${val})); + } else { + $empty = 1; + } + delete($hash_ref->{$key}) if $empty; + return; +} + +sub cleanup_group_state { + my ($state, $group_id, $backlog) = @_; + my ($members); + my $group_data = $state->{'groups'}{$group_id}; + $members = $group_data->{'members'}; + if (not exists($ACTIVE_GROUPS{$group_id}) or not $members) { + # No members left, remove the group entirely + delete($state->{'groups'}{$group_id}); + if (not exists($ACTIVE_GROUPS{$group_id})) { + log_debug("Group ${group_id} dropped: It is not an active group"); + } else { + log_debug("Group ${group_id} dropped: No members left (early)"); + } + + return; + } + + for my $member_id (sort(keys(%{$members}))) { + if (not exists($KNOWN_MEMBERS{"${group_id} ${member_id}"})) { + delete($members->{$member_id}); + if (not $group_data->{'out-of-date'}) { + $group_data->{'out-of-date'} = 1; + log_debug( + "${group_id} is out-of-date: ${member_id} disappeared"); + } + } else { + my $member_data = $members->{$member_id}; + # Create "member_id to group_data" link + $state->{'members-to-groups'}{$member_id} = $group_data; + delete($member_data->{'mirror-metadata'}{'component'}) + if exists($member_data->{'mirror-metadata'}); + remove_if_empty($member_data, 'mirror-metadata'); + } + } + + # Add the "out-of-date" flag if it is in the backlog OR we were asked + # to reschedule all + if (not $group_data->{'out-of-date'}) { + if ($OPT{'reschedule-all'} or $backlog->{$group_id}) { + $group_data->{'out-of-date'} = 1; + log_debug("Marking ${group_id} as out of date: In backlog") + if $backlog->{$group_id}; + } + } + # Check for and possible clear the error counters + if ( + exists($group_data->{'processing-errors'}) + and (not exists($group_data->{'last-error-by'}) + or $group_data->{'last-error-by'} ne $OPT{'desired-version'}) + ) { + log_debug( + "Clearing error-counter for ${group_id}: New version of lintian"); + delete($group_data->{'processing-errors'}); + # Leave "last-error-by" as we can use that to tell if the previous + # version triggered errors. + } + + if (not %{$members}) { + # No members left, remove the group entirely. This should not happen + # as the ACTIVE_GROUPS check above ought to have caught this. + delete($state->{$group_id}); + log_debug("Group ${group_id} dropped: No members left (late)"); + } else { + # remove redundant fields + remove_if_empty($group_data, 'out-of-date'); + for my $metadata_field (qw(component maintainer uploaders)) { + remove_if_empty($group_data->{'mirror-metadata'}, $metadata_field); + } + remove_if_empty($group_data, 'mirror-metadata'); + } + + return; +} + +# Helper for local_mirror_manifests - it parses a paragraph from Sources file +sub _parse_srcs_pg { + my ($state, $blacklist, $extra_metadata, $paragraph) = @_; + my $dir = $paragraph->{'Directory'}//''; + my $group_id = $paragraph->{'Package'} . '/' . $paragraph->{'Version'}; + my $member_id = "source:${group_id}"; + my (%data, %group_metadata, $group_mirror_md); + if (exists $blacklist->{$paragraph->{'Package'}}) { + log_debug("Ignoring blacklisted package src:$paragraph->{'Package'}"); + return; + } + # only include the source if it has any binaries to be checked. + # - Otherwise we may end up checking a source with no binaries + # (happens if the architecture is "behind" in building) + return unless $ACTIVE_GROUPS{$group_id}; + $dir .= '/' if $dir; + foreach my $f (split m/\n/, $paragraph->{"Checksums-${DEFAULT_CHECKSUM}"}){ + + # trim both ends + $f =~ s/^\s+|\s+$//g; + + next unless $f && $f =~ m/\.dsc$/; + my ($checksum, undef, $basename) = split(m/\s++/, $f); + my $b64_checksum = encode_base64(pack('H*', $checksum)); + # $dir should end with a slash if it is non-empty. + $data{lc $DEFAULT_CHECKSUM} = $b64_checksum; + $data{'path'} = $extra_metadata->{'mirror-dir'} . "/$dir" . $basename; + last; + } + + $group_mirror_md = $group_metadata{'mirror-metadata'} = {}; + $group_mirror_md->{'component'} = $extra_metadata->{'component'}; + $group_mirror_md->{'maintainer'} = $paragraph->{'maintainer'}; + if (my $uploaders = $paragraph->{'uploaders'}) { + my @ulist = split(/>\K\s*,\s*/, $uploaders); + $group_mirror_md->{'uploaders'} = \@ulist; + } + + add_member_to_group($state, $group_id, $member_id, \%data, + \%group_metadata); + return; +} + +# Helper for local_mirror_manifests - it parses a paragraph from Packages file +sub _parse_pkgs_pg { + my ($state, $blacklist, $extra_metadata, $type, $paragraph) = @_; + my ($group_id, $member_id, %data, %group_metadata, $b64_checksum); + my $package = $paragraph->{'Package'}; + my $version = $paragraph->{'Version'}; + my $architecture = $paragraph->{'Architecture'}; + if (not defined($paragraph->{'Source'})) { + $paragraph->{'Source'} = $package; + } elsif ($paragraph->{'Source'} =~ /^([-+\.\w]+)\s+\((.+)\)$/) { + $paragraph->{'Source'} = $1; + $paragraph->{'Source-version'} = $2; + } + if (exists $blacklist->{$paragraph->{'Source'}}) { + log_debug("Ignoring binary package $package: it is part of " + . "blacklisted source package $paragraph->{'Source'}"); + return; + } + if (not defined($paragraph->{'Source-Version'})) { + $paragraph->{'Source-Version'} = $paragraph->{'Version'}; + } + $group_id = $paragraph->{'Source'} . '/' . $paragraph->{'Source-Version'}; + $member_id = "${type}:${package}/${version}/${architecture}"; + $data{'path'} + = $extra_metadata->{'mirror-dir'} . '/' . $paragraph->{'filename'}; + $b64_checksum + = encode_base64(pack('H*', $paragraph->{lc $DEFAULT_CHECKSUM})); + $data{lc $DEFAULT_CHECKSUM} = $b64_checksum; + + $group_metadata{'mirror-metadata'}{'maintainer'} + = $paragraph->{'Maintainer'}; + if (my $uploaders = $paragraph->{'Uploaders'}) { + my @ulist = split(/>\K\s*,\s*/, $uploaders); + $group_metadata{'mirror-metadata'}{'uploaders'} = \@ulist; + } + + add_member_to_group($state, $group_id, $member_id, \%data, + \%group_metadata); + return; +} + +# local_mirror_manifests ($mirdir, $dists, $components, $archs) +# +# Returns a list of manifests that represents what is on the local mirror +# at $mirdir. 3 manifests will be returned, one for "source", one for "binary" +# and one for "udeb" packages. They are populated based on the "Sources" and +# "Packages" files. +# +# $mirdir - the path to the local mirror +# $dists - listref of dists to consider (e.g. ['unstable']) +# $components - listref of components to consider (e.g. ['main', 'contrib', 'non-free']) +# $archs - listref of archs to consider (e.g. ['i386', 'amd64']) +# $blacklist - hashref of source packages to ignore (e.g. {'gcc-8-cross-ports' => 1}) +# +sub local_mirror_manifests { + my ($state, $mirdir, $dists, $components, $archs, $blacklist) = @_; + foreach my $dist (@$dists) { + foreach my $component (@{$components}) { + my $srcs = "$mirdir/dists/$dist/$component/source/Sources"; + + my %extra_metadata = ( + 'component' => $component, + 'mirror-dir' => $mirdir, + ); + + # Binaries have a "per arch" file. + # - we check those first and then include the source packages that + # are referred to by these binaries. + + my $dist_path = "$mirdir/dists/$dist/$component"; + for my $arch (@{$archs}) { + + my $pkgs = "${dist_path}/binary-$arch/Packages"; + my $pkgfd = _open_data_file($pkgs); + local $/ = undef; + my $pkgstring = <$pkgfd>; + close $pkgfd; + + my $binsub = sub { + _parse_pkgs_pg($state, $blacklist, \%extra_metadata, + 'binary', @_); + }; + visit_dpkg_paragraph_string($binsub, $pkgstring); + + my $upkgs + = "${dist_path}/debian-installer/binary-$arch/Packages"; + my $upkgfd = _open_data_file($upkgs); + local $/ = undef; + my $upkgstring = <$upkgfd>; + close $upkgfd; + + my $udebsub = sub { + _parse_pkgs_pg($state, $blacklist, \%extra_metadata, + 'udeb', @_); + }; + visit_dpkg_paragraph_string($udebsub, $upkgstring); + } + + my $srcfd = _open_data_file($srcs); + local $/ = undef; + my $srcstring = <$srcfd>; + close $srcfd; + + my $srcsub + = sub { _parse_srcs_pg($state, $blacklist, \%extra_metadata, @_) }; + visit_dpkg_paragraph_string($srcsub, $srcstring); + } + } + return; +} + +# _open_data_file ($file) +# +# Opens $file if it exists, otherwise it tries common extensions (i.e. .gz) and opens +# that instead. It may pipe the file through an external decompressor, so the returned +# file descriptor cannot be assumed to be a file. +# +# If $file does not exists and no common extensions are found, this dies. It may also +# die if it finds a file, but is unable to open it. +sub _open_data_file { + my ($file) = @_; + if (-e $file) { + open(my $fd, '<:encoding(UTF-8)', $file); + return $fd; + } + if (-e "${file}.gz") { + my $fd = open_gz("${file}.gz"); + binmode($fd, 'encoding(UTF-8)'); + return $fd; + } + if (-e "${file}.xz") { + open(my $fd, '-|', 'xz', '-dc', "${file}.xz"); + binmode($fd, 'encoding(UTF-8)'); + return $fd; + } + die("Cannot find ${file}: file does not exist"); +} + +sub log_debug { + if ($OPT{'debug'}) { + print "$_[0]\n"; + } + return; +} + +sub usage { + my $cmd = basename($0); + my $me = "lintian $cmd"; + print <<EOF; +Internal command for the Lintian reporting framework +Usage: $me <args> + + --help Show this text and exit + --debug Show/log debugging output + + --reporting-config FILE + Path to the configuration file (listing the archive definitions) [!] + --desired-version X The desired "last-processed-by" Lintian version. [!] + +Arguments marked with [!] are required for a successful run. + +EOF + + exit(0); +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |