#!/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/&/\&amp;/g;
    }
    if (index($text, '<') > -1) {
        $text =~ s/</\&lt;/g;
    }
    if (index($text, '>') > -1) {
        $text =~ s/>/\&gt;/g;
    }
    if (index($text, '/') > -1) {
        $text =~ s/\//\&#x2f;/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
