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