head 1.2; access; symbols; locks; strict; comment @# @; 1.2 date 2005.01.24.15.41.15; author thl; state dead; branches; next 1.1; 1.1 date 2005.01.18.08.53.48; author thl; state Exp; branches; next ; desc @@ 1.2 log @remove build farm utilities from release engineering @ text @#!@@l_prefix@@/bin/perl -w ## ## OpenPKG bfui.pl - OpenPKG build farm user interface (used as CGI) ## Copyright (c) 2002-2005 The OpenPKG Project ## Copyright (c) 2002-2005 Ralf S. Engelschall ## Copyright (c) 2002-2005 Cable & Wireless ## ## 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. ## require 5.008; use strict; use OpenPKG::Ctx; use CGI; use String::Divert; use Data::Dumper; use IO::File; use DBI; use DBD::SQLite; # configure optional debugging $Data::Dumper::Purity = 1; $Data::Dumper::Indent = 1; $Data::Dumper::Terse = 1; # determine OpenPKG information my $ctx = new OpenPKG::Ctx; my $prefix = $ctx->prefix(); # configuration my $dbfile = "$prefix/var/bfdb.sqlite"; my $verbose = undef; my $pasture = "/e/openpkg/bf"; # logs expected below $pasture/log/$inst/ # internal handling of fatal errors BEGIN { $SIG{__DIE__} = sub { my ($msg) = @@_; my $hint = ''; if ($msg =~ m|line\s+(\d+)|) { my $line = $1; my $io = new IO::File "<$0"; my @@code = $io->getlines(); $io->close(); my $i = -1; $hint = join("", map { s/^/sprintf("%d: ", $line+$i++)/se; $_; } @@code[$line-2..$line]); } print STDOUT "Content-Type: text/html; charset=ISO-8859-1\n" . "\n" . "\n" . " \n" . " GURU MEDITATION\n" . " \n" . " \n" . " \n" . " \n" . "
\n" . "
\n" . " GURU MEDITATION\n" . "

\n" . " \n" . " $msg
\n" . "
\n" . "

\n$hint
\n" . "
\n" . "
\n" . " \n" . "\n"; exit(0); }; } # catch and hold time my $time = time(); # create objects my $cgi = new CGI; my $dbh = &dbinit($dbfile); my $html = new String::Divert; $html->overload(1); ## ## Generate Canvas ## # generate outer canvas $html .= "\n"; $html .= " "; $html->fold("bf"); $html .= "
\n"; ## ## Generate View Part ## $html >> "bf"; if ($cgi->param("page") eq "css") { $html .= &cssexit(); } elsif ($cgi->param("page") eq "processing") { $html .= &viewmain(); $html .= &viewprocessingform(); $html .= &viewprocessing(); } elsif ($cgi->param("page") eq "status") { $html .= &viewmain(); $html .= &viewstatusform(); $html .= &viewstatus(); } elsif ($cgi->param("page") eq "matrix") { $html .= &viewmain(); $html .= &viewmatrix(); } elsif ($cgi->param("page") eq "log") { $html .= &viewmain(); $html .= &viewlog($cgi->param("file"), $cgi->param("mode")); } else { $cgi->delete_all(); $html .= "

url() . "?page=processing\">processing

\n"; $html .= &viewprocessingform(); $html .= "shows build farm package processing in real time\n"; $html .= "

url() . "?page=status\">status

\n"; $html .= &viewstatusform(); $html .= "shows package status per inst (host-arch-os) or package (name-version-release)\n"; $html .= "

url() . "?page=matrix\">matrix

\n"; $html .= "shows grand total package status\n"; $html .= "
NOTE: takes approximately 100 seconds to compute before data transfer starts\n"; } $html << 1; ## ## Generate HTTP Reponse ## # HTML skeleton my $skel = ""; $skel .= "\n"; $skel .= " \n"; $skel .= " \n"; $skel .= " \n"; $skel .= " \n"; $skel .= " \n"; $skel .= "

OpenPKG build farm

\n"; $skel .= " %BODY%\n"; $skel .= " \n"; $skel .= "\n"; # undivert HTML output and wrap with skeleton $html->undivert(0); $skel =~ s|\%BODY\%|$html|s; $html = $skel; # create HTTP response my $header = {}; $header->{type} = 'text/html'; $header->{expires} = '+10s'; $header->{refresh} = $cgi->param("vp_autorefresh") . "; " . $cgi->url() . "?page=processing&vp_autorefresh=" . $cgi->param("vp_autorefresh") if ($cgi->param("vp_autorefresh") > 0); my $http = $cgi->header($header); $http .= $html; print STDOUT $http; # die gracefully ;-) $dbh->disconnect(); undef $dbh; exit(0); sub cssexit () { my $css = ''; $css .= "/*\n"; $css .= "** bfui.cgi - OpenPKG build farm user interface CGI\n"; $css .= "*/\n"; $css .= "\n"; $css .= "TABLE.bf {\n"; $css .= " background: #f0f0f0;\n"; $css .= " font-family: sans-serif, helvetica, arial;\n"; $css .= "}\n"; $css .= "\n"; $css .= ".bf TD.browse {\n"; $css .= " width: 100%;\n"; $css .= " background: #d0d0d0;\n"; $css .= "}\n"; $css .= ".bf TD.browse SPAN.title {\n"; $css .= " font-weight: bold;\n"; $css .= " font-size: 200%;\n"; $css .= " color: #000000;\n"; $css .= "}\n"; $css .= ".bf TD.query {\n"; $css .= " width: 100%;\n"; $css .= " background: #d0d0d0;\n"; $css .= "}\n"; $css .= ".bf TD.query SPAN.title {\n"; $css .= " font-weight: bold;\n"; $css .= " font-size: 200%;\n"; $css .= " color: #000000;\n"; $css .= "}\n"; $css .= ".bf TD.view {\n"; $css .= " width: 100%;\n"; $css .= " background: #d0d0d0;\n"; $css .= "}\n"; $css .= ".bf TD.view SPAN.title {\n"; $css .= " font-weight: bold;\n"; $css .= " font-size: 200%;\n"; $css .= " color: #000000;\n"; $css .= "}\n"; $css .= ".bf TD.result {\n"; $css .= " width: 100%;\n"; $css .= " background: #d0d0d0;\n"; $css .= "}\n"; $css .= ".bf TD.result SPAN.title {\n"; $css .= " font-weight: bold;\n"; $css .= " font-size: 200%;\n"; $css .= " color: #000000;\n"; $css .= "}\n"; # create HTTP response my $header = {}; $header->{type} = 'text/html'; $header->{expires} = '+10s'; my $http = $cgi->header($header); $http .= $css; print STDOUT $http; exit(0); } sub viewmain() { my $rv; my $html; $html .= $cgi->start_form(); $html .= $cgi->submit('page','main'); $html .= $cgi->end_form; return $html; } sub viewprocessingform() { my $rv; my $html; $html .= $cgi->start_form(); $html .= $cgi->submit('submit','processing'); $html .= " autorefresh "; $html .= $cgi->popup_menu( -name => "vp_autorefresh", -value => [ "0", "3", "10", "60", "300", "900", "3600" ], -labels => { "0" => "never", "3" => "3 secs", "10" => "10 secs", "60" => "1 min", "300" => "5 min", "900" => "15 min", "3600" => "1h" }, -default => "0", ) . "\n"; $html .= $cgi->hidden(-name=>'page', -value => "processing"); $html .= $cgi->end_form; return $html; } sub viewstatusform() { my $rv; my $html; my @@color; $rv = $dbh->selectall_arrayref("SELECT DISTINCT st_build_color " . "FROM status " . "ORDER BY st_build_color;"); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } foreach my $i (@@{$rv}) { push @@color, @@{$i}->[0]; } my @@inst; $rv = $dbh->selectall_arrayref("SELECT DISTINCT st_inst_host, st_inst_arch, st_inst_os " . "FROM status " . "ORDER BY st_inst_host, st_inst_arch, st_inst_os;"); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } foreach my $i (@@{$rv}) { push @@inst, @@{$i}->[0] . "-" . @@{$i}->[1] . "-" . @@{$i}->[2]; } $html .= $cgi->start_form(); $html .= $cgi->submit('submit','host-arch-os'); $html .= " "; $html .= $cgi->popup_menu( -name => "vs_inst", -value => \@@inst, ) . "\n"; $html .= $cgi->popup_menu( -name => "vs_color", -value => \@@color, -default => "", ) . "\n"; $html .= $cgi->hidden(-name=>'page', -value => "status"); $html .= $cgi->end_form; my @@package; $rv = $dbh->selectall_arrayref("SELECT DISTINCT st_package_name, st_package_version, st_package_release " . "FROM status " . "ORDER BY st_package_name, st_package_version, st_package_release;"); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } foreach my $i (@@{$rv}) { push @@package, @@{$i}->[0] . "-" . @@{$i}->[1] . "-" . @@{$i}->[2]; } $html .= $cgi->start_form(); $html .= $cgi->submit('submit','name-version-release'); $html .= " "; $html .= $cgi->popup_menu( -name => "vs_package", -value => \@@package, ) . "\n"; $html .= $cgi->popup_menu( -name => "vs_color", -value => \@@color, -default => "", ) . "\n"; $html .= $cgi->hidden(-name=>'page', -value => "status"); $html .= $cgi->end_form; return $html; } sub viewlog() { my ($logfile, $mode) = @@_; my $html; if ($logfile =~ m|\.\.| or $logfile =~ m |^/|) { die "PANIC:$0: Intruder detected"; } if ( -f "$pasture/log/$logfile" and -r "$pasture/log/$logfile" and -s "$pasture/log/$logfile" ) { my $file; my $io = new IO::File "<$pasture/log/$logfile" or die "unable to read logfile \"$logfile\""; $file .= $_ while (<$io>); $io->close(); $file =~ s|&|&|sg; $file =~ s|<|<|sg; $file =~ s|>|>|sg; $file =~ s;^(Executing\((%|--).+?\):.*?)$;$1;mg; $file =~ s|^(\+[^\n]*)$|$1|mg; $file =~ s;^(.*warn.*)$;$1;mgi; $file =~ s;^(.*(error|abort|fail|fatal|bad|illegal|invalid|usage|denied).*)$;$1;mgi; $html .= "
\n$file\n
\n"; } else { $html .= "Sorry, the logfile \"$logfile\" does not exist yet or not exist any longer"; } return $html; } sub viewprocessing() { my $rv; my $html; $rv = $dbh->selectall_hashref("SELECT * FROM processing;", "pr_inst_host"); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } $html .= "

url() . "?page=processing\">processing

\n"; $html .= "\n"; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= "\n"; for my $i (sort keys %{$rv}) { $html .= ""; # color (unused in realtime processing) $html .= ""; # host-arch-os my ($host, $arch, $os, $tag) = (%{$rv}->{$i}->{pr_inst_host}, %{$rv}->{$i}->{pr_inst_arch}, %{$rv}->{$i}->{pr_inst_os}, %{$rv}->{$i}->{pr_inst_tag}); my $inst .= $host . "-" . $arch . "-" . $os; $html .= ""; # name-version-release or "not building" my ($name, $version, $release) = (%{$rv}->{$i}->{pr_package_name}, %{$rv}->{$i}->{pr_package_version}, %{$rv}->{$i}->{pr_package_release}); my $package .= $name . "-" . $version . "-" . $release; if ($name eq "") { $html .= ""; } else { my $logfile = "$inst/$package.log.$host.$arch-$os-$tag"; if ( -f "$pasture/log/$logfile" and -r "$pasture/log/$logfile" and -s "$pasture/log/$logfile" ) { $html .= ""; } else { $html .= ""; } } # since or "idle"; duration my $heartbeat = %{$rv}->{$i}->{pr_heartbeat}; if ($heartbeat eq "") { $html .= ""; $html .= ""; } else { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($heartbeat); $html .= sprintf "", $year+1900, $mon+1, $mday, $hour, $min, $sec; $html .= ""; } $html .= "\n"; } $html .= "
 host-arch-osname-version-releasebuilding sinceduration
\"processing\"url() . "?page=status&submit=host-arch-os&vs_inst=$host-$arch-$os\">$inst" . " not buildingurl() . "?page=log&mode=tail&file=$logfile\">$package$packageidle %04s-%02s-%02s %02s:%02s:%02s"; my $duration = $time - $heartbeat; if ($duration < 60) { $html .= $duration . " seconds"; } elsif ($duration < 60 * 60) { $html .= int($duration/60) . " minutes"; } elsif ($duration < 60 * 60 * 24) { $html .= "" . int($duration/60/60) . " hours"; } elsif ($duration < 60 * 60 * 24 * 7) { $html .= "" . int($duration/60/60/24) . " days"; } else { $html .= "weeks"; } $html .= "
"; return $html; } # split inst "bsd1-ix86-freebsd5.3-openpkg" into host="bsd1", arch="ix86", os="freebsd5.3" and tag="openpkg" sub splitinst ($) { my ($inst) = @@_; my ($host, $arch, $os, $tag); if ($inst =~ m|^(.+)-([^-]+)-([^-]+)-([^-]+)$|) { ($host, $arch, $os, $tag) = ($1, $2, $3, $4); }; return ($host, $arch, $os, $tag); } # split package "perl-openpkg-5.8.6-20041203" into name="perl-openpkg", version="5.8.6" and release="20041203" sub splitpackage ($) { my ($package) = @@_; my ($name, $version, $release); if ($package =~ m|^(.+)-([^-]+)-([^-]+)$|) { ($name, $version, $release) = ($1, $2, $3); }; return ($name, $version, $release); } sub viewmatrix() { my $html; my ($sth, $rv); $html .= "

url() . "?page=matrix\">matrix

\n"; my @@insts; $rv = $dbh->selectall_arrayref("SELECT DISTINCT st_inst_host, st_inst_arch, st_inst_os " . "FROM status " . "ORDER BY st_inst_host, st_inst_arch, st_inst_os;"); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } foreach my $i (@@{$rv}) { push @@insts, @@{$i}->[0] . "-" . @@{$i}->[1] . "-" . @@{$i}->[2]; } my @@packages; $rv = $dbh->selectall_arrayref("SELECT DISTINCT st_package_name, st_package_version, st_package_release " . "FROM status " . "ORDER BY st_package_name, st_package_version, st_package_release;"); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } foreach my $i (@@{$rv}) { push @@packages, @@{$i}->[0] . "-" . @@{$i}->[1] . "-" . @@{$i}->[2]; } $html .= "
\n";
    $sth = $dbh->prepare(
        "SELECT st_inst_host, st_inst_arch, st_inst_os, st_build_color FROM status WHERE ( " .
        "    st_package_name like ? and st_package_version like ? and st_package_release like ? and " .
        "    st_build_color like ? );"
    );
    foreach my $package (@@packages) {
        my ($name, $version, $release) = &splitpackage($package);
        $rv = $sth->execute(
            $name, $version, $release,
            "%"
        );
        if (not $rv) {
            die "ERROR:$0: SQLite error: ".$dbh->errstr."\n";
        }
        $rv = $sth->fetchall_arrayref();
        my $row = {};
        for my $i (@@{$rv}) {
            $row->{@@{$i}->[0] . "-" . @@{$i}->[1] . "-" . @@{$i}->[2]} = @@{$i}->[3];
        }
        foreach my $inst (@@insts) {
            my ($host, $arch, $os, $tag) = &splitinst($inst . "-openpkg"); # bsd1-ix86-freebsd5.3-openpkg

            my $logfile = "$inst/$package.log.$host.$arch-$os-$tag";
            my ($l, $r);
            if ( -f "$pasture/log/$logfile" and -r "$pasture/log/$logfile" and -s "$pasture/log/$logfile" ) {
                $l = "url() . "?page=log&mode=tail&file=$logfile\">";
                $r = "";
            }
            else {
                $l = "";
                $r = "";
            }

            my $color = $row->{$inst};
            if ($color eq "green") {
                $html .= "$l\"green\"$r";
            }
            elsif ($color eq "red") {
                $html .= "$l\"red\"$r";
            }
            else {
                $html .= "$l\"$color\"$r";
            }
        }
        $html .= " url() . "?page=status&submit=name-version-release&vs_package=$package\">$package\n";
    }
    $html .= "
"; return $html; } sub viewstatus() { my ($host, $arch, $os, $tag) = &splitinst("%-%-%-%"); # bsd1-ix86-freebsd5.3-openpkg my ($name, $version, $release) = &splitpackage("%-%-%"); # perl-5.8.6-20050111 my ($color) = "%"; # red my ($sth, $rv); my $html; $html .= "

url() . "?page=status\">status

\n"; if ($cgi->param("submit") eq "host-arch-os") { ($host, $arch, $os, $tag) = &splitinst($cgi->param("vs_inst") . "-openpkg"); ($name, $version, $release) = &splitpackage("%-%-%") } if ($cgi->param("submit") eq "name-version-release") { ($host, $arch, $os, $tag) = &splitinst("%-%-%-openpkg"); ($name, $version, $release) = &splitpackage($cgi->param("vs_package")); } if ($cgi->param("vs_color") eq "") { $color = "%"; } else { $color = $cgi->param("vs_color"); } $sth = $dbh->prepare( "SELECT * FROM status WHERE ( " . " st_inst_host like ? and st_inst_arch like ? and st_inst_os like ? and st_inst_tag like ? and " . " st_package_name like ? and st_package_version like ? and st_package_release like ? and " . " st_build_color like ? );" ); $rv = $sth->execute( $host, $arch, $os, $tag, $name, $version, $release, $color ); if (not $rv) { die "ERROR:$0: SQLite error: ".$dbh->errstr."\n"; } $rv = $sth->fetchall_arrayref({}); $html .= "\n"; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= ""; $html .= "\n"; for my $i (@@{$rv}) { $html .= ""; my $color = %{$i}->{st_build_color}; my ($host, $arch, $os, $tag) = (%{$i}->{st_inst_host}, %{$i}->{st_inst_arch}, %{$i}->{st_inst_os}, %{$i}->{st_inst_tag}); my ($name, $version, $release) = (%{$i}->{st_package_name}, %{$i}->{st_package_version}, %{$i}->{st_package_release}); # color if ($color eq "green") { $html .= ""; } elsif ($color eq "red") { $html .= ""; } else { $html .= ""; } # host-arch-os my $inst .= $host . "-" . $arch . "-" . $os; $html .= ""; # cvs $html .= ""; $html .= ""; $html .= ""; # name-version-release or "not building" my $package .= $name . "-" . $version . "-" . $release; my $logfile = "$inst/$package.log.$host.$arch-$os-$tag"; if ( -f "$pasture/log/$logfile" ) { $html .= ""; } else { $html .= ""; } $html .= "\n"; } $html .= "
 host-arch-ostimespecdirname-version-release
\"green\"\"red\"\"$color\"url() . "?page=status&submit=host-arch-os&vs_inst=$host-$arch-$os\">$inst" . " timespecdir"; $html .= "url() . "?page=status&submit=name-version-release&vs_package=$name-$version-$release\">$name" . " "; $html .= "-$version-"; $html .= "url() . "?page=log&mode=highlight&file=$logfile\">$release"; $html .= ""; $html .= "url() . "?page=status&submit=name-version-release&vs_package=$name-$version-$release\">$name" . " "; $html .= "-$version-"; $html .= "$release"; $html .= "
"; return $html; } # open database and check whether important tables exist sub dbinit ($) { my ($dbfile) = @@_; my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", "", "", { RaiseError => 0, AutoCommit => 1 }); if (not defined $dbh) { die "$0: \"cannot open database file \"$dbfile\"\n"; } my $tables = $dbh->selectall_hashref("SELECT name FROM sqlite_master WHERE type='table' ORDER BY name;", "name"); unless ($tables->{status}) { die "$0: \"status\" table missing in database file \"$dbfile\"\n"; } unless ($tables->{processing}) { die "$0: \"processing\" table missing in database file \"$dbfile\"\n"; } unless ($tables->{class}) { die "$0: \"class\" table missing in database file \"$dbfile\"\n"; } return $dbh; } __END__ =pod =head1 NAME B - OpenPKG build farm user interface =head1 SYNOPSIS used as CGI =head1 DESCRIPTION =cut @ 1.1 log @OpenPKG build farm database and user interface The build farm master creates Makefiles for the slaves which run them to build packages and drop resulting binaries (if any) along with logs on a shared storage. This behavior remains unchanged. Currently the master picks up logs from preconfigured slaves, creates a status report through a lengthy process and uploads status and logs to the primary OpenPKG web server. Disadvantage is the maintenance required to register the slaves for processing on the master and viewing on the web server and bad scalability because the workload on the master increases with every new slave. The delay in status processing does not provide realtime information. The communcation bandwith, CPU horsepower and disk space on the primary web server are constantly utilized with status and logfile updates in addition to serving the resulting status pages to engineers. The build farm database does not require registration of slaves, it uses the security infrastructure which already exists to trigger Makefile execution and log file writing. In addition, the database and tables are created on the fly making it virtually maintenance free. All connected slaves upload status information in realtime using the bfdb.pl shell interface. Remote shell execution just needs to be plugged into the Makefile and does not add any new requirements to the slaves software portfolio. The need for the master to pick up and process logs and the associated maintenance efforts, scalability problems and realtime limitations are fully eliminated. A local webserver running on the master allows access to status and logs in realtime, offloading such tasks from the primary OpenPKG web server completely. @ text @@