The branch, master has been updated
via 52a2144 Remove now obsolete hostdb.pm.
via 6cccf14 Switch over to using python import-and-analyse.
via 90150b8 Fix blame mail sending.
from c3b0245 Try a bit harder to not fetch from the upload directory
when looking for old builds.
http://gitweb.samba.org/?p=build-farm.git;a=shortlog;h=master
- Log -----------------------------------------------------------------
commit 52a21444c38370270d31dd604934e56727aa8128
Author: Jelmer Vernooij <[email protected]>
Date: Sat Nov 13 20:00:40 2010 +0100
Remove now obsolete hostdb.pm.
commit 6cccf1436f7a41a8f63051bccade9f4a2ab309ee
Author: Jelmer Vernooij <[email protected]>
Date: Sat Nov 13 19:57:47 2010 +0100
Switch over to using python import-and-analyse.
commit 90150b8b7b08904b4ec880822f3208a34c2467ec
Author: Jelmer Vernooij <[email protected]>
Date: Sat Nov 13 19:56:28 2010 +0100
Fix blame mail sending.
-----------------------------------------------------------------------
Summary of changes:
build.pm | 9 -
hostdb.pm | 236 ----------------------------
import-and-analyse.pl | 407 -------------------------------------------------
import-and-analyse.py | 5 +-
revs.sh | 2 +-
tests/hostdb.pl | 74 ---------
web/trees.conf | 2 +-
7 files changed, 4 insertions(+), 731 deletions(-)
delete mode 100644 build.pm
delete mode 100644 hostdb.pm
delete mode 100755 import-and-analyse.pl
delete mode 100755 tests/hostdb.pl
Changeset truncated at 500 lines:
diff --git a/build.pm b/build.pm
deleted file mode 100644
index 7de9cc7..0000000
--- a/build.pm
+++ /dev/null
@@ -1,9 +0,0 @@
-package BuildFarm;
-
-use strict;
-
-use vars qw ( $VERSION );
-
-$VERSION = '0.01';
-
-1;
diff --git a/hostdb.pm b/hostdb.pm
deleted file mode 100644
index 372483d..0000000
--- a/hostdb.pm
+++ /dev/null
@@ -1,236 +0,0 @@
-#!/usr/bin/perl
-
-# Samba.org buildfarm
-# Copyright (C) 2008 Andrew Bartlett <[email protected]>
-# Copyright (C) 2008 Jelmer Vernooij <[email protected]>
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 3 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, see <http://www.gnu.org/licenses/>.
-#
-
-package hostdb;
-
-use DBI;
-use warnings;
-use strict;
-
-sub new($)
- {
- my ($class, $filename) = @_;
-
- my $dbh = DBI->connect("dbi:SQLite:$filename", "", "", {RaiseError => 1,
PrintError => 0,
- ShowErrorStatement => 1, AutoCommit => 0}) or return
undef;
-
- my $self = { filename => $filename, dbh => $dbh };
-
- bless($self, $class);
-}
-
-sub provision($)
-{
- my ($self) = @_;
- eval {
- $self->{dbh}->do("CREATE TABLE host ( name text, owner text,
owner_email text, password text, ssh_access int, fqdn text, platform text,
permission text, last_dead_mail int, join_time int );");
-
- $self->{dbh}->do("CREATE UNIQUE INDEX unique_hostname ON host
(name);");
-
- $self->{dbh}->do("CREATE TABLE build ( id integer primary key
autoincrement, tree text, revision text, host text, compiler text, checksum
text, age int, status text, commit_revision text);");
- $self->{dbh}->do("CREATE UNIQUE INDEX unique_checksum ON build
(checksum);");
-
- $self->{dbh}->do("CREATE TABLE test_run ( build int, test text,
result text, output text);");
- $self->{dbh}->commit();
- };
- if ($@) {
- local $self->{dbh}->{RaiseError} = 0;
- $self->{dbh}->rollback();
- print "DB Failure: $@";
- return 0;
- }
- return 1;
-}
-
-sub createhost($$$$$$)
-{
- my ($self, $name, $platform, $owner, $owner_email, $password,
$permission) = @_;
- my $sth = $self->{dbh}->prepare("INSERT INTO host (name, platform,
owner, owner_email, password, permission, join_time) VALUES (?,?,?,?,?,?,?)");
-
- eval {
- $sth->execute($name, $platform, $owner, $owner_email, $password,
$permission, time());
- $self->{dbh}->commit();
- };
- if ($@) {
- local $self->{dbh}->{RaiseError} = 0;
- $self->{dbh}->rollback();
- print "DB Failure: $@";
- return 0;
- }
- return 1;
-}
-
-sub deletehost($$)
-{
- my ($self, $name) = @_;
- my $ret;
- my $sth = $self->{dbh}->prepare("DELETE FROM host WHERE name = ?");
-
- eval {
- $ret = $sth->execute($name);
- $self->{dbh}->commit();
- };
- if ($@) {
- local $self->{dbh}->{RaiseError} = 0;
- $self->{dbh}->rollback();
- print "DB Failure: $@";
- return 0;
- }
-
- return ($ret == 1);
-}
-
-sub hosts($)
-{
- my ($self) = @_;
-
- return $self->{dbh}->selectall_arrayref("SELECT * FROM host ORDER BY
name", { Slice => {} });
-}
-
-sub dead_hosts($$)
-{
- my ($self, $age) = @_;
- my $dead_age = time() - $age;
- return $self->{dbh}->selectall_arrayref("SELECT host.name AS host,
host.owner AS owner, host.owner_email AS owner_email, MAX(age) AS last_update
FROM host LEFT JOIN build ON ( host.name == build.host) WHERE
ifnull(last_dead_mail, 0) < $dead_age AND ifnull(join_time, 0) < $dead_age
GROUP BY host.name having ifnull(MAX(age),0) < $dead_age", { Slice => {} });
-}
-
-sub host_ages($)
-{
- my ($self) = @_;
- return $self->{dbh}->selectall_arrayref("SELECT host.name AS host,
host.owner AS owner, host.owner_email AS owner_email, MAX(age) AS last_update
FROM host LEFT JOIN build ON ( host.name == build.host) GROUP BY host.name
ORDER BY age", { Slice => {} });
-}
-
-sub sent_dead_mail($$)
-{
- my ($self, $host) = @_;
- my $changed;
- eval {
- $changed = $self->{dbh}->do("UPDATE host SET last_dead_mail = ?
WHERE name = ?", undef,
- (time(), $host));
- $self->{dbh}->commit();
- };
- if ($@) {
- local $self->{dbh}->{RaiseError} = 0;
- $self->{dbh}->rollback();
- print "DB Failure: $@";
- return 0;
- }
-
- return ($changed == 1);
-}
-
-sub host($$)
-{
- my ($self, $name) = @_;
-
- my $hosts = $self->hosts();
-
- foreach (@$hosts) {
- return $_ if ($_->{name} eq $name);
- }
-
- return undef;
-}
-
-sub update_platform($$$)
-{
- my ($self, $name, $new_platform) = @_;
- my $changed;
-
- eval {
- $changed = $self->{dbh}->do("UPDATE host SET platform = ? WHERE
name = ?", undef,
- ($new_platform, $name));
- $self->{dbh}->commit();
- };
- if ($@) {
- local $self->{dbh}->{RaiseError} = 0;
- $self->{dbh}->rollback();
- print "DB Failure: $@";
- return 0;
- }
-
- return ($changed == 1);
-}
-
-sub update_owner($$$$)
-{
- my ($self, $name, $new_owner, $new_owner_email) = @_;
- my $changed;
-
- eval {
- $changed = $self->{dbh}->do("UPDATE host SET owner = ?, owner_email
= ? WHERE name = ?",
- undef, ($new_owner, $new_owner_email,
$name));
- $self->{dbh}->commit();
- };
- if ($@) {
- local $self->{dbh}->{RaiseError} = 0;
- $self->{dbh}->rollback();
- return 0;
- }
-
- return ($changed == 1);
-}
-
-# Write out the rsyncd.secrets
-sub create_rsync_secrets($)
-{
- my ($db) = @_;
-
- my $hosts = $db->hosts();
-
- my $res = "";
-
- $res .= "# rsyncd.secrets file\n";
- $res .= "# automatically generated by textfiles.pl. DO NOT EDIT!\n\n";
-
- foreach (@$hosts) {
- $res .= "# $_->{name}";
- if ($_->{owner}) {
- $res .= ", owner: $_->{owner} <$_->{owner_email}>\n";
- } else {
- $res .= ", owner unknown\n";
- }
- if ($_->{password}) {
- $res .= "$_->{name}:$_->{password}\n\n";
- } else {
- $res .= "# $->{name} password is unknown\n\n";
- }
- }
-
- return $res;
-}
-
-# Write out the web/
-sub create_hosts_list($)
-{
- my ($self) = @_;
-
- my $res = "";
-
- my $hosts = $self->hosts();
-
- foreach (@$hosts) {
- $res .= "$_->{name}: $_->{platform}\n";
- }
-
- return $res;
-}
-
-1;
diff --git a/import-and-analyse.pl b/import-and-analyse.pl
deleted file mode 100755
index 84663d1..0000000
--- a/import-and-analyse.pl
+++ /dev/null
@@ -1,407 +0,0 @@
-#!/usr/bin/perl
-# Write sqlite entries for test reports in the build farm
-# Copyright (C) 2007 Jelmer Vernooij <[email protected]>
-# Published under the GNU GPL
-
-use FindBin qw($RealBin $Script);
-use lib "$RealBin/web";
-use DBI;
-use Digest::SHA1 qw(sha1_hex);
-use strict;
-use util;
-use File::stat;
-use File::Copy;
-use Getopt::Long;
-use hostdb;
-use data;
-use Carp;
-
-my $opt_help = 0;
-my $opt_verbose = 0;
-my $dry_run = 0;
-my $result = GetOptions('help|h|?' => \$opt_help,
- 'dry-run|n' => sub { $dry_run++; },
- 'verbose|v' => sub { $opt_verbose++; });
-
-exit(1) unless ($result);
-
-if ($opt_help) {
- print "$Script [OPTIONS]\n";
- print "Options:\n";
- print " --help This help message\n";
- print " --verbose Be verbose\n";
- print " --dry-run Dry run\n";
- exit;
-
- print <<EOU;
-
-Script to parse build farm log files from the data directory, import
-them into the database, add links to the oldrevs/ directory and send
-some mail chastising the possible culprits when the build fails, based
-on recent commits.
-
--n Will cause the script to send output to stdout instead of
- to sendmail.
-EOU
- exit(1);
-}
-
-my $unpacked_dir = "/home/ftp/pub/unpacked";
-
-# we open readonly here as only apache(www-run) has write access
-my $db = new data($RealBin, 1);
-
-my $hostdb = new hostdb("$RealBin/hostdb.sqlite");
-
-my $dbh = $hostdb->{dbh};
-
-my @compilers = @{$db->{compilers}};
-my @hosts = @{$db->{hosts_list}};
-my %trees = %{$db->{trees}};
-
-sub get_log_svn($$$$$)
-{
- my ($host, $tree, $compiler, $cur, $old) = @_;
- my $firstrev = $old->{rev} + 1;
- my $cmd = "svn log --non-interactive -r $firstrev:$cur->{rev}
$unpacked_dir/$tree";
- my $log = undef;
-
- $log->{change_log} = `$cmd` || confess "$cmd: failed";
- #print($log->{change_log});
-
- # get the list of possible culprits
- my $log2 = $log->{change_log};
-
- while ($log2 =~ /\nr\d+ \| (\w+) \|.*?line(s?)\n(.*)$/s) {
- $log->{committers}->{"[email protected]"} = 1;
- $log2 = $3;
- }
-
- # Add a URL to the diffs for each change
- $log->{change_log} =~
s/\n(r(\d+).*)/\n$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
-
- $log->{recipients} = $log->{committers};
-
- return $log;
-}
-
-sub get_log_git($$$$$)
-{
- my ($host, $tree, $compiler, $cur, $old) = @_;
- my $cmd = "cd $unpacked_dir/$tree && git log --pretty=full
$old->{rev}..$cur->{rev} ./";
- my $log = undef;
-
- $log->{change_log} = `$cmd` || confess "$cmd: failed";
- #print($log->{change_log});
-
- # get the list of possible culprits
- my $log2 = $log->{change_log};
-
- while ($log2 =~ /[\n]*Author: [^<]*<([^>]+)>\nCommit:
[^<]*<([^>]+)>\n(.*)$/s) {
- my $author = $1;
- my $committer = $2;
- $log2 = $3;
-
- # handle cherry-picks from svnmirror repo
- $author =~ s/0c0555d6-39d7-0310-84fc-f1cc0bd64818/samba\.org/;
-
- # for now only send reports to samba.org addresses.
- $author = undef unless $author =~ /\...@samba\.org/;
- # $committer = undef unless $committer =~ /\...@samba\.org/;
-
- $log->{authors}->{$author} = 1 if defined($author);
- $log->{committers}->{$committer} = 1 if defined($committer);
- }
-
- # Add a URL to the diffs for each change
- $log->{change_log} =~ s/([\n]*commit
([0-9a-f]+))/$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
-
- my @all = ();
- push(@all, keys %{$log->{authors}}) if defined($log->{authors});
- push(@all, keys %{$log->{committers}}) if defined($log->{committers});
- my $all = undef;
- foreach my $k (@all) {
- $all->{$k} = 1;
- }
- $log->{recipients} = $all;
-
- return $log;
-}
-
-sub get_log($$$$$)
-{
- my ($host, $tree, $compiler, $cur, $old) = @_;
- my $treedir = "$unpacked_dir/$tree";
-
- if (-d "$treedir/.svn") {
- return get_log_svn($host, $tree, $compiler, $cur, $old);
- } elsif (-d "$treedir/.git") {
- return get_log_git($host, $tree, $compiler, $cur, $old);
- }
-
- return undef;
-}
-
-sub check_and_send_mails($$$$$)
-{
- my ($tree, $host, $compiler, $cur, $old) = @_;
- my $t = $trees{$tree};
-
- printf("rev=$cur->{rev} status=$cur->{string}\n") if $dry_run;
-
- printf("old rev=$old->{rev} status=$old->{string}\n") if $dry_run;
-
- my $cmp = $db->status_info_cmp($old, $cur);
-#printf("cmp: $cmp\n");
-
- if ($cmp <= 0) {
- printf("the build didn't get worse ($cmp)\n") if $dry_run;
- return unless $dry_run;
- }
-
- my $log = get_log($host, $tree, $compiler, $cur, $old);
- if (not defined($log)) {
- printf("no log\n") if $dry_run;
- return;
- }
-
- my $recipients = undef;
- $recipients = join(",", keys %{$log->{recipients}}) if
defined($log->{recipients});
-
- my $subject = "BUILD of $tree:$t->{branch} BROKEN on $host with $compiler
AT REVISION $cur->{rev}";
-
-# send the nastygram
- if ($dry_run) {
- print "To: $recipients\n" if defined($recipients);
- print "Subject: $subject\n";
- open(MAIL,"|cat");
- } else {
- if (defined($recipients)) {
- open(MAIL,"|Mail -a \"Content-Type: text/plain;charset=utf-8\" -a
\"Precedence: bulk\" -s \"$subject\" $recipients");
- } else {
- open(MAIL,"|cat >/dev/null");
- }
- }
-
- my $body = << "__EOF__";
-Broken build for tree $tree on host $host with compiler $compiler
-
-Tree $tree is $t->{scm} branch $t->{branch}.
-
-Build status for new revision $cur->{rev} is $cur->{string}
-Build status for old revision $old->{rev} was $old->{string}
-
-See
http://build.samba.org/?function=View+Build;host=$host;tree=$tree;compiler=$compiler
-
-The build may have been broken by one of the following commits:
-
-$log->{change_log}
-__EOF__
- print MAIL $body;
-
- close(MAIL);
-}
-
-
-foreach my $host (@hosts) {
- foreach my $tree (keys %trees) {
- foreach my $compiler (@compilers) {
- my $rev;
- my $commit;
- my $retry = 0;
- if ($opt_verbose >= 2) {
- print "Looking for a log file for $host $compiler $tree...\n";
- }
-
- # By building the log file name this way, using only the list of
- # hosts, trees and compilers as input, we ensure we
- # control the inputs
- my $logfn = $db->build_fname($tree, $host, $compiler);
- my $stat = stat($logfn . ".log");
- next if (!$stat);
-
- if ($opt_verbose >= 2) {
- print "Processing $logfn...\n";
- }
-
- eval {
- my $expression = "SELECT checksum FROM build WHERE age >= ? AND
tree = ? AND host = ? AND compiler = ?";
- my $st = $dbh->prepare($expression);
-
- $st->execute($stat->ctime, $tree, $host, $compiler);
-
- # Don't bother if we've already processed this file
- my $relevant_rows = $st->fetchall_arrayref();
-
- $st->finish();
-
--
build.samba.org
