import-and-analyse.pl

   1 #!/usr/bin/perl
   2 # Write sqlite entries for test reports in the build farm
   3 # Copyright (C) 2007 Jelmer Vernooij <jelmer@samba.org>
   4 # Published under the GNU GPL
   5
   6 use FindBin qw($RealBin $Script);
   7 use lib "$RealBin/web";
   8 use DBI;
   9 use Digest::SHA1 qw(sha1_hex);
  10 use strict;
  11 use util;
  12 use File::stat;
  13 use Getopt::Long;
  14 use hostdb;
  15 use data;
  16 use Carp;
  17
  18 my $opt_help = 0;
  19 my $opt_verbose = 0;
  20 my $dry_run = 0;
  21 my $result = GetOptions('help|h|?' => \$opt_help,
  22                         'dry-run|n' => sub { $dry_run++; },
  23                         'verbose|v' => sub { $opt_verbose++; });
  24
  25 exit(1) unless ($result);
  26
  27 if ($opt_help) {
  28         print "$Script [OPTIONS]\n";
  29         print "Options:\n";
  30         print " --help         This help message\n";
  31         print " --verbose      Be verbose\n";
  32         print " --dry-run      Dry run\n";
  33         exit;
  34
  35         print <<EOU;
  36
  37 Script to parse build farm log files from the data directory, import
  38 them into the database, add links to the oldrevs/ directory and send
  39 some mail chastising the possible culprits when the build fails, based
  40 on recent commits.
  41
  42 -n  Will cause the script to send output to stdout instead of
  43     to sendmail.
  44 EOU
  45         exit(1);
  46 }
  47
  48 my $unpacked_dir = "/home/ftp/pub/unpacked";
  49
  50 # we open readonly here as only apache(www-run) has write access
  51 my $db = new data($RealBin, 1);
  52
  53 my $hostdb = new hostdb("$RealBin/hostdb.sqlite");
  54
  55 my $dbh = $hostdb->{dbh};
  56
  57 my @compilers = @{$db->{compilers}};
  58 my @hosts = @{$db->{hosts_list}};
  59 my %trees = %{$db->{trees}};
  60
  61 sub get_log_svn($$$$$)
  62 {
  63         my ($host, $tree, $compiler, $cur, $old) = @_;
  64         my $firstrev = $old->{rev} + 1;
  65         my $cmd = "svn log --non-interactive -r $firstrev:$cur->{rev} $unpacked_dir/$tree";
  66         my $log = undef;
  67
  68         $log->{change_log} = `$cmd` || confess "$cmd: failed";
  69         #print($log->{change_log});
  70
  71         # get the list of possible culprits
  72         my $log2 = $log->{change_log};
  73
  74         while ($log2 =~ /\nr\d+ \| (\w+) \|.*?line(s?)\n(.*)$/s) {
  75                 $log->{committers}->{"$1\@samba.org"} = 1;
  76                 $log2 = $3;
  77         }
  78
  79         # Add a URL to the diffs for each change
  80         $log->{change_log} =~ s/\n(r(\d+).*)/\n$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
  81
  82         $log->{recipients} = $log->{committers};
  83
  84         return $log;
  85 }
  86
  87 sub get_log_git($$$$$)
  88 {
  89         my ($host, $tree, $compiler, $cur, $old) = @_;
  90         my $cmd = "cd $unpacked_dir/$tree && git log --pretty=full $old->{rev}..$cur->{rev} ./";
  91         my $log = undef;
  92
  93         $log->{change_log} = `$cmd` || confess "$cmd: failed";
  94         #print($log->{change_log});
  95
  96         # get the list of possible culprits
  97         my $log2 = $log->{change_log};
  98
  99         while ($log2 =~ /[\n]*Author: [^<]*<([^>]+)>\nCommit: [^<]*<([^>]+)>\n(.*)$/s) {
 100                 my $author = $1;
 101                 my $committer = $2;
 102                 $log2 = $3;
 103
 104                 # handle cherry-picks from svnmirror repo
 105                 $author =~ s/0c0555d6-39d7-0310-84fc-f1cc0bd64818/samba\.org/;
 106
 107                 # for now only send reports to samba.org addresses.
 108                 $author = undef unless $author =~ /\@samba\.org/;
 109                 # $committer = undef unless $committer =~ /\@samba\.org/;
 110
 111                 $log->{authors}->{$author} = 1 if defined($author);
 112                 $log->{committers}->{$committer} = 1 if defined($committer);
 113         }
 114
 115         # Add a URL to the diffs for each change
 116         $log->{change_log} =~ s/([\n]*commit ([0-9a-f]+))/$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
 117
 118         my @all = ();
 119         push(@all, keys %{$log->{authors}}) if defined($log->{authors});
 120         push(@all, keys %{$log->{committers}}) if defined($log->{committers});
 121         my $all = undef;
 122         foreach my $k (@all) {
 123                 $all->{$k} = 1;
 124         }
 125         $log->{recipients} = $all;
 126
 127         return $log;
 128 }
 129
 130 sub get_log($$$$$)
 131 {
 132         my ($host, $tree, $compiler, $cur, $old) = @_;
 133         my $treedir = "$unpacked_dir/$tree";
 134
 135         if (-d "$treedir/.svn") {
 136                 return get_log_svn($host, $tree, $compiler, $cur, $old);
 137         } elsif (-d "$treedir/.git") {
 138                 return get_log_git($host, $tree, $compiler, $cur, $old);
 139         }
 140
 141         return undef;
 142 }
 143
 144 sub check_and_send_mails($$$$$)
 145 {
 146     my ($tree, $host, $compiler, $cur, $old) = @_;
 147     my $t = $trees{$tree};
 148
 149     printf("rev=$cur->{rev} status=$cur->{string}\n") if $dry_run;
 150
 151     printf("old rev=$old->{rev} status=$old->{string}\n") if $dry_run;
 152
 153     my $cmp = $db->status_info_cmp($old, $cur);
 154 #printf("cmp: $cmp\n");
 155
 156     if ($cmp <= 0) {
 157         printf("the build didn't get worse ($cmp)\n") if $dry_run;
 158         return unless $dry_run;
 159     }
 160
 161     my $log = get_log($host, $tree, $compiler, $cur, $old);
 162     if (not defined($log)) {
 163         printf("no log\n") if $dry_run;
 164         return;
 165     }
 166
 167     my $recipients = undef;
 168     $recipients = join(",", keys %{$log->{recipients}}) if defined($log->{recipients});
 169
 170     my $subject = "BUILD of $tree:$t->{branch} BROKEN on $host with $compiler AT REVISION $cur->{rev}";
 171
 172 # send the nastygram
 173     if ($dry_run) {
 174         print "To: $recipients\n" if defined($recipients);
 175         print "Subject: $subject\n";
 176         open(MAIL,"|cat");
 177     } else {
 178         if (defined($recipients)) {
 179             open(MAIL,"|Mail -a \"Content-Type: text/plain;charset=utf-8\" -s \"$subject\" $recipients");
 180         } else {
 181             open(MAIL,"|cat >/dev/null");
 182         }
 183     }
 184
 185     my $body = << "__EOF__";
 186 Broken build for tree $tree on host $host with compiler $compiler
 187
 188 Tree $tree is $t->{scm} branch $t->{branch}.
 189
 190 Build status for new revision $cur->{rev} is $cur->{string}
 191 Build status for old revision $old->{rev} was $old->{string}
 192
 193 See http://build.samba.org/?function=View+Build;host=$host;tree=$tree;compiler=$compiler
 194
 195 The build may have been broken by one of the following commits:
 196
 197 $log->{change_log}
 198 __EOF__
 199     print MAIL $body;
 200
 201     close(MAIL);
 202 }
 203
 204
 205 foreach my $host (@hosts) {
 206     foreach my $tree (keys %trees) {
 207         foreach my $compiler (@compilers) {
 208             if ($opt_verbose >= 2) {
 209                 print "Looking for a log file for $host $compiler $tree...\n";
 210             }
 211
 212             # By building the log file name this way, using only the list of
 213             # hosts, trees and compilers as input, we ensure we
 214             # control the inputs
 215             my $logfn = $db->build_fname($tree, $host, $compiler);
 216             my $stat = stat($logfn . ".log");
 217             next if (!$stat);
 218
 219             if ($opt_verbose >= 2) {
 220                 print "Processing $logfn...\n";
 221             }
 222
 223             my $st = $dbh->prepare("SELECT checksum FROM build WHERE age >= ? AND tree = ? AND host = ? AND compiler = ?");
 224
 225             $st->execute($stat->mtime, $tree, $host, $compiler) or die("Unable to check for existing build data");
 226
 227             # Don't bother if we've already processed this file
 228             my $relevant_rows = $st->fetchall_arrayref();
 229
 230             next if ($#$relevant_rows > -1);
 231
 232             # By reading the log file this way, using only the list of
 233             # hosts, trees and compilers as input, we ensure we
 234             # control the inputs
 235             my $data = util::FileLoad($logfn.".log");
 236
 237             # Don't bother with empty logs, they have no meaning (and would all share the same checksum)
 238             if (not $data or $data eq "") {
 239                 next;
 240             }
 241
 242             my $err = util::FileLoad($logfn.".err");
 243             $err = "" unless defined($err);
 244
 245             $dbh->begin_work() or die "could not get transaction lock";
 246
 247             my $checksum = sha1_hex($data);
 248             if ($dbh->selectrow_array("SELECT checksum FROM build WHERE checksum = '$checksum'")) {
 249                 $dbh->do("UPDATE BUILD SET age = ? WHERE checksum = ?", undef,
 250                          ($stat->mtime, $checksum));
 251                 next;
 252             }
 253             if ($opt_verbose) { print "$logfn\n"; }
 254
 255             my ($rev) = ($data =~ /BUILD REVISION: ([^\n]+)/);
 256             my $commit;
 257
 258             if ($data =~ /BUILD COMMIT REVISION: (.*)/) {
 259                 $commit = $1;
 260             } else {
 261                 $commit = $rev;
 262             }
 263             my $status_html = $db->build_status_from_logs($data, $err);
 264
 265             # Look up the database to find the previous status
 266             $st = $dbh->prepare("SELECT status, revision, commit_revision FROM build WHERE tree = ? AND host = ? AND compiler = ? AND revision != ? AND commit_revision != ? ORDER BY id DESC LIMIT 1");
 267             $st->execute( $tree, $host, $compiler, $rev, $commit) or die "Could not search for existing build";
 268
 269             my $old_status_html;
 270             my $old_rev;
 271             my $old_commit;
 272             while ( my @row = $st->fetchrow_array ) {
 273                 $old_status_html = @row[0];
 274                 $old_rev = @row[1];
 275                 $old_commit = @row[2];
 276             }
 277
 278
 279             $st = $dbh->prepare("INSERT INTO build (tree, revision, commit_revision, host, compiler, checksum, age, status) VALUES (?, ?, ?, ?, ?, ?, ?, ?)");
 280             $st->execute($tree, $rev, $commit, $host, $compiler, $checksum, $stat->mtime, $status_html);
 281
 282
 283 #   SKIP This code, as it creates massive databases, until we get code to use the information, and a way to expire the results
 284 #           my $build = $dbh->func('last_insert_rowid');
 285 #
 286 #           $st = $dbh->prepare("INSERT INTO test_run (build, test, result, output) VALUES ($build, ?, ?, ?)");
 287 #
 288 #           while ($data =~ /--==--==--==--==--==--==--==--==--==--==--.*?
 289 #       Running\ test\ ([\w\-=,_:\ \/.&;]+).*?
 290 #       --==--==--==--==--==--==--==--==--==--==--
 291 #       (.*?)
 292 #       ==========================================.*?
 293 #       TEST\ (FAILED|PASSED|SKIPPED):.*?
 294 #       ==========================================\s+
 295 #       /sxg) {
 296 #               # Note: output is discarded ($2)
 297 #               $st->execute($1, $3, undef);
 298 #           }
 299
 300             $st->finish();
 301
 302             my $cur_status = $db->build_status_info_from_html($rev, $commit, $status_html);
 303             my $old_status;
 304
 305             # Can't send a nastygram until there are 2 builds..
 306             if (defined($old_status_html)) {
 307                 $old_status = $db->build_status_info_from_html($old_rev, $old_commit, $old_status_html);
 308                 check_and_send_mails($tree, $host, $compiler, $cur_status, $old_status);
 309             }
 310
 311             if ($dry_run) {
 312                 $dbh->rollback;
 313                 next;
 314             }
 315
 316             $dbh->commit or die "Could not commit transaction";
 317             if ($rev) {
 318                 # If we were able to put this into the DB (ie, a
 319                 # one-off event, so we won't repeat this), then also
 320                 # hard-link the log files to the revision, if we know
 321                 # it.
 322
 323
 324                 # This ensures that the names under 'oldrev' are well known and well formed
 325                 my $log_rev = $db->build_fname($tree, $host, $compiler, $rev) . ".log";
 326                 my $err_rev = $db->build_fname($tree, $host, $compiler, $rev) . ".err";
 327                 unlink $log_rev;
 328                 unlink $err_rev;
 329                 link($logfn, $log_rev);
 330                 link($db->build_fname($tree, $host, $compiler) . ".err", $err_rev);
 331             }
 332         }
 333     }
 334 }