#!/v/openpkg/sw/bin/perl
##
##  Copyright (c) 2000-2006 OpenPKG Foundation e.V. <http://openpkg.net/>
##  Copyright (c) 2000-2006 Ralf S. Engelschall <http://engelschall.com/>
##
##  Permission to use, copy, modify, and distribute this software for
##  any purpose with or without fee is hereby granted, provided that
##  the above copyright notice and this permission notice appear in all
##  copies.
##
##  THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
##  SUCH DAMAGE.
##
##  tracker.cgi -- OpenPKG Tool Chain, Version Tracker, CGI User Interface
##

#   requirements
require 5;
use DBI;
use DBD::SQLite;
use DBIx::Simple;
use CGI;
use CGI::GuruMeditation (-name => "OpenPKG tracker", -debug => 1);
use String::Divert;
use IO::File;
use Date::Format;
use HTML::Entities;
use strict;
use warnings;

#   program information
my $progname = "tracker";
my $progvers = "0.9.0";
my $database = "tracker.db";

#   establish CGI query object
my $cgi = new CGI;

#   establish Database query object
my $db = DBIx::Simple->connect(
    "dbi:SQLite:dbname=$database", "", "",
    { RaiseError => 0, AutoCommit => 0 }
) or die "unable to open database";

#   establish HTML output object
my $html = new String::Divert;
$html->folder('{#%s#}', '\{#([a-zA-Z_][a-zA-Z0-9_-]*)#\}');
$html->overload(1);
my $io = new IO::File "<tracker.cgi.page.html" or die;
my $canvas = ''; $canvas .= $_ while (<$io>);
$io->close();
$canvas =~ s/<!-- TRACKER HEAD -->/$html->folder("head")/sie;
$canvas =~ s/<!-- TRACKER SIDE -->/$html->folder("side")/sie;
$canvas =~ s/<!-- TRACKER BODY -->/$html->folder("body")/sie;
$html->append($canvas);

#   provide inner HTML canvas
$html->divert("head");
$html .= "<link rel=\"stylesheet\" type=\"text/css\" href=\"tracker.css\"/>\n";
$html->undivert();
$html->divert("body");
$html .= "<div class=\"tracker\">\n";
$html .= "  "; $html->fold();
$html .= "<\/div>\n";
$html->divert();

#   determine tracking ids
my ($t_id_max) = $db->query(q{
    SELECT tracking, MAX(time) AS time FROM tracking;
})->list();
$t_id_max ||= 1;
my $t_id = $cgi->param("tid") || $t_id_max;
$t_id = $t_id_max if ($t_id !~ m/^\d+$/s);

my $result = $db->query(q{
    SELECT time, duration_rpm, duration_vcheck FROM tracking WHERE tracking = ?;
}, $t_id)->hash() or die "unable to find tracking #$t_id";
my $time = time2str("%Y-%m-%d %H:%M", $result->{"time"});
my $duration;
my $status;
if ($result->{"duration_vcheck"} > 0) {
    $duration = $result->{"duration_rpm"} + $result->{"duration_vcheck"};
    $status = "<span class=\"completed\">completed</span>";
}
else {
    $duration = time() - $result->{"time"};
    $status = "<span class=\"inprogress\">still in progress</span>";
}
my $sec  = $duration % 60; $duration /= 60;
my $min  = $duration % 60; $duration /= 60;
my $hour = $duration;
$duration = sprintf("%02d:%02d:%02d", $hour, $min, $sec);
my ($n_src) = $db->query(q{
    SELECT COUNT(*) FROM status WHERE tracking = ?;
}, $t_id)->list();
my ($n_pkg) = $db->query(q{
    SELECT COUNT(*) FROM (SELECT DISTINCT package FROM status WHERE tracking = ?);
}, $t_id)->list();
my ($n_old) = $db->query(q{
    SELECT COUNT(*) FROM status WHERE tracking = ? AND new == old AND new NOT LIKE "ERROR:%";
}, $t_id)->list();
my ($n_new) = $db->query(q{
    SELECT COUNT(*) FROM status WHERE tracking = ? AND new != old AND new NOT LIKE "ERROR:%";
}, $t_id)->list();
my ($n_err) = $db->query(q{
    SELECT COUNT(*) FROM status WHERE tracking = ? AND new != old AND new LIKE "ERROR:%";
}, $t_id)->list();
my ($n_dis) = $db->query(q{
    SELECT COUNT(*) FROM package WHERE package.disabled = 1;
})->list() or die $db->error();

$html->divert("side");
$html .= "<p/>\n";
$html .= "<b>Browse Trackings:</b><br/>\n";
if ($t_id > 1) {
    $html .= sprintf("<a href=\"%s?tid=%d\">&larr; previous</a>", $cgi->url(-relative => 1), $t_id - 1);
}
$html .= " &nbsp; ";
if ($t_id < $t_id_max) {
    $html .= sprintf("<a href=\"%s?tid=%d\">next &rarr;</a>", $cgi->url(-relative => 1), $t_id + 1);
}
$html .= "<p/>\n";
$html .= "<b>Select Tracking:</b><br/>\n";
foreach my $t ($db->query(q{
    SELECT tracking, time, duration_rpm, duration_vcheck FROM tracking ORDER BY time DESC LIMIT 10;
})->hashes()) {
    $html .= sprintf("<a href=\"%s?tid=%d\">%s</a><br/>\n",
        $cgi->url(-relative => 1), $t->{"tracking"}, time2str("%Y-%m-%d %H:%M", $t->{"time"}));
}
$html .= "<p/>\n";
$html .= "<b>Hint about Information:</b><br/>\n";
$html .= "The information of these reports are based on the results of bi-daily running " .
         "<a href=\"http://cvs.openpkg.org/openpkg-src/vcheck/\">vcheck</a>(1) " .
         "on the <tt>\%track</tt> sections of all " .
         "<a href=\"http://cvs.openpkg.org/openpkg-src/\">OpenPKG CURRENT</a> packages.\n";
$html->undivert();

$html .= "<p/>\n";
$html .= "<table class=\"header\">\n";
$html .= "  <tr><td>Tracking Time:</td>        <td>$time</td></tr>\n";
$html .= "  <tr><td>Tracking Duration:</td>    <td>$duration (H:M:S)</td></tr>\n";
$html .= "  <tr><td>Tracking Status:</td>      <td>$status</td></tr>\n";
$html .= "  <tr><td>Tracking Input:</td>       <td>$n_src sources ($n_pkg packages)</td></tr>\n";
$html .= "  <tr><td>Tracking Result:</td>      <td>$n_old up-to-date, $n_new out-dated, $n_err error ($n_dis disabled)</td></tr>\n";
$html .= "</table>\n";

sub class2icon {
    my ($class) = @_;
    my $icon = {
        CORE => '&hearts;',
        BASE => '&radic;',
        PLUS => '&otimes;',
        EVAL => '&oslash;',
        JUNK => '&times;',
    }->{$class};
    return "<span class=\"$class\">$icon</span>";
}

$html .= "<h2>Requests for Upgrading</h2>\n";

$html .= "The following $n_new sources were determined to be out-dated because newer\n" .
         "vendor versions were found. An upgrade of the corresponding OpenPKG packages is requested.\n" .
         "The packages are grouped by the total number of previous equal subsequent successful trackings and with\n" .
         "the lowest numbered group first. Within each group the packages are sorted by class and then alphabetically. " .
         "The latest packages are shown in bold type face. Packages which were already changed " .
         "between tracking time and report display time are annotated with a green check mark. " .
         "Packages are annotated with their short summary and quality class information (legend: ";
$html .= class2icon("CORE") . " CORE, ";
$html .= class2icon("BASE") . " BASE, ";
$html .= class2icon("PLUS") . " PLUS, ";
$html .= class2icon("EVAL") . " EVAL, ";
$html .= class2icon("JUNK") . " JUNK";
$html .= ").";

$html .= "<p/>\n";
$html .= "<table class=\"report1\">\n";
$html .= sprintf(
    "  <tr class=\"header\">\n" .
    "    <td class=\"package\">%s</td>\n" .
    "    <td class=\"old\">%s</td>\n" .
    "    <td class=\"new\">%s</td>\n" .
    "    <td class=\"hint\">%s</td>\n" .
    "  </tr>\n",
    "package[:component]", "current version", "new version", "hint"
);

my $i = 0;
my $k = 1;
my @k = ();
my $c = 0;
foreach my $result ($db->query(q{
    SELECT
        status.package as package,
        status.component as component,
        status.old as old,
        status.new as new,
        package.url as url,
        package.comment as comment,
        count.count as count,
        updated.updated as updated,
        package.class as class,
        ( CASE 
             WHEN package.class = 'CORE' THEN 0
             WHEN package.class = 'BASE' THEN 1
             WHEN package.class = 'PLUS' THEN 2
             WHEN package.class = 'EVAL' THEN 3
             WHEN package.class = 'JUNK' THEN 4
             ELSE                             5
          END
        ) AS class_order
    FROM
        status, package,
        ( SELECT 
              package, component, MAX(time) as time, count
          FROM (
              SELECT package, component, time, COUNT(new) AS count
              FROM status
              WHERE tracking <= ?
              GROUP BY package, component, new
              ORDER BY time
          ) GROUP BY package, component
        ) AS count,
        ( SELECT
              package.package as package, package.component as component,
              (CASE WHEN package.md5 = cache.md5 THEN 0 ELSE 1 END) as updated
          FROM
              package, cache
          WHERE
              package.package = cache.package
        ) AS updated
    WHERE
        status.tracking = ? AND
        status.package = package.package AND
        status.component = package.component AND
        status.package = count.package AND
        status.component = count.component AND
        status.package = updated.package AND
        status.component = updated.component AND
        status.new != status.old AND
        status.new NOT LIKE "ERROR:%"
    ORDER BY
        count, class_order, status.package, status.component;
}, $t_id, $t_id)->hashes()) {
    my $hint = "";
    if ($result->{"comment"} ne '') {
        $hint = sprintf("[&nbsp;<a name=\"r1l%d\"></a><a href=\"#r1c%d\">%d</a>&nbsp;]", $k, $k, $k);
        push(@k, { -k => $k, -comment => $result->{"comment"} });
        $k++;
    }
    $hint = "<span class=\"updated\">\&radic;</span>&nbsp;" . $hint if ($result->{"updated"} and $t_id == $t_id_max);
    $html .= sprintf(
        "  <tr class=\"a%d%s%s\">\n" .
        "    <td class=\"package\"><a href=\"%s\">%s%s</a>&nbsp;%s</td>\n" .
        "    <td class=\"old\">%s</td>\n" .
        "    <td class=\"new\">%s</td>\n" .
        "    <td class=\"hint\">%s</td>\n" .
        "  </tr>\n",
        $i, 
        $result->{"count"} != $c ? " sep" : "",
        $result->{"count"} == 1 ? " freshest" : "",
        encode_entities($result->{"url"}),
        $result->{"package"}, $result->{"component"} ? ": " . $result->{"component"} : "",
        class2icon($result->{"class"}),
        $result->{"old"}, $result->{"new"}, $hint
    );
    $i = ($i + 1) % 2;
    $c = $result->{"count"};
}
$html .= "</table>\n";
$html .= "<p/>\n";
if (@k > 0) {
    $html .= "<table class=\"comment\">\n";
    foreach my $k (@k) {
        $html .= sprintf("  <tr><td>[&nbsp;<a name=\"r1c%d\"></a><a href=\"#r1l%d\">%d</a>&nbsp;]&nbsp;</td><td>%s</td></tr>\n",
            $k->{-k}, $k->{-k}, $k->{-k}, $k->{-comment});
    }
    $html .= "</table>\n";
}

$html .= "<h2>Requests for Fixing</h2>\n";

$html .= "The following $n_err sources could not be successfully checked because\n" .
         "an error occurred while processing. Keep at least an eye on them.\n" .
         "The packages are grouped by the total number of previous equal subsequent failed trackings and with\n" .
         "the highest numbered group first. Within each group the packages are sorted alphabetically.";

$html .= "<p/>\n";
$html .= "<table class=\"report2\">\n";
$html .= sprintf(
    "  <tr class=\"header\">" .
    "    <td class=\"package\">%s</td>\n" .
    "    <td class=\"old\">%s</td>\n" .
    "    <td class=\"new\">%s</td>\n" .
    "    <td class=\"hint\">%s</td>\n" .
    "  </tr>\n",
    "package[:component]", "current version", "version tracking error", "hint"
);
$i = 0;
$k = 1;
@k = ();
$c = 0;
foreach my $result ($db->query(q{
    SELECT 
        status.package as package,
        status.component as component,
        status.old as old,
        status.new as new,
        package.url as url,
        package.comment as comment,
        count.count as count,
        updated.updated as updated,
        package.class as class,
        ( CASE 
             WHEN package.class = 'CORE' THEN 0
             WHEN package.class = 'BASE' THEN 1
             WHEN package.class = 'PLUS' THEN 2
             WHEN package.class = 'EVAL' THEN 3
             WHEN package.class = 'JUNK' THEN 4
             ELSE                             5
          END
        ) AS class_order
    FROM 
        status, package,
        ( SELECT 
              package, component, MAX(time) as time, count
          FROM (
              SELECT package, component, time, COUNT(new) AS count
              FROM status
              WHERE tracking <= ?
              GROUP BY package, component, new
              ORDER BY time
          ) GROUP BY package, component
        ) AS count,
        ( SELECT
              package.package as package, package.component as component,
              (CASE WHEN package.md5 = cache.md5 THEN 0 ELSE 1 END) as updated
          FROM
              package, cache
          WHERE
              package.package = cache.package
        ) AS updated
    WHERE
        tracking = ? AND
        status.package = package.package AND
        status.component = package.component AND
        status.package = count.package AND
        status.component = count.component AND
        status.package = updated.package AND
        status.component = updated.component AND
        status.new != status.old AND
        status.new LIKE "ERROR:%"
    ORDER BY
        count DESC, class_order, status.package ASC, status.component ASC;
}, $t_id, $t_id)->hashes()) {
    my $hint = "";
    if ($result->{"comment"} ne '') {
        $hint = sprintf("[&nbsp;<a name=\"r2l%d\"></a><a href=\"#r2c%d\">%d</a>&nbsp;]", $k, $k, $k);
        push(@k, { -k => $k, -comment => $result->{"comment"} });
        $k++;
    }
    $hint = "<span class=\"updated\">\&radic;</span>&nbsp;" . $hint if ($result->{"updated"} and $t_id == $t_id_max);
    my $error = $result->{"new"};
    $error =~ s/^ERROR:\s*//s;
    $html .= sprintf(
        "  <tr class=\"a%d%s\">\n" .
        "    <td class=\"package\"><a href=\"%s\">%s%s</a>&nbsp;%s</td>\n" .
        "    <td class=\"old\">%s</td>\n" .
        "    <td class=\"new\">%s</td>\n" .
        "    <td class=\"hint\">%s</td>\n" .
        "  </tr>\n",
        $i, 
        $result->{"count"} != $c ? " sep" : "",
        encode_entities($result->{"url"}),
        $result->{"package"}, $result->{"component"} ? ": " . $result->{"component"} : "",
        class2icon($result->{"class"}),
        $result->{"old"}, $error, $hint
    );
    $i = ($i + 1) % 2;
    $c = $result->{"count"};
}
$html .= "</table>\n";
$html .= "<p/>\n";
if (@k > 0) {
    $html .= "<table class=\"comment\">\n";
    foreach my $k (@k) {
        $html .= sprintf("  <tr><td>[&nbsp;<a name=\"r2c%d\"></a><a href=\"#r2l%d\">%d</a>&nbsp;]&nbsp;</td><td>%s</td></tr>\n",
            $k->{-k}, $k->{-k}, $k->{-k}, $k->{-comment});
    }
    $html .= "</table>\n";
}

#   send output 
$html->overload(0);
$html->undivert(0);
$html = $html->string();
print $cgi->header(
    -type           => "text/html",
    -Content_length => length($html),
    -X_User_Agent   => sprintf("%s/%s", $progname, $progvers),
    -Cache_Control  => "max-age=0",
    -expires        => "+0s",
) . $html;

#   close database
$db->commit();
$db->disconnect();
undef $db;

#   die gracefully
exit(0);