b57655c75ae8f375dd031bba2a866f7fa091c23a
[buildfarm-server.git] / cgi-bin / eximstatus.pl
1 #!/usr/bin/perl
2
3 =comment
4
5 Copyright (c) 2003-2010, Andrew Dunstan
6
7 See accompanying License file for license details
8
9 =cut 
10
11 use strict;
12
13 use vars qw($dbhost $dbname $dbuser $dbpass $dbport
14        $all_stat $fail_stat $change_stat $green_stat
15        $server_time
16            $min_script_version $min_web_script_version
17        $default_host $local_git_clone
18 );
19
20 # force this before we do anything - even load modules
21 BEGIN { $server_time = time; }
22
23 use CGI;
24 use Digest::SHA1  qw(sha1_hex);
25 use MIME::Base64;
26 use DBI;
27 use DBD::mysql;
28 use Data::Dumper;
29 use Mail::Send;
30 use Time::ParseDate;
31 use Storable qw(thaw);
32
33 require "$ENV{BFConfDir}/BuildFarmWeb.pl";
34 my $buildlogs = "$ENV{BFConfDir}/buildlogs";
35
36 die "no dbname" unless $dbname;
37 die "no dbuser" unless $dbuser;
38
39 my $dsn="dbi:mysql:dbname=$dbname";
40 $dsn .= ";host=$dbhost" if $dbhost;
41 $dsn .= ";port=$dbport" if $dbport;
42
43 my $query = new CGI;
44
45 my $sig = $query->path_info;
46 $sig =~ s!^/!!;
47
48 my $stage = $query->param('stage');
49 my $ts = $query->param('ts');
50 my $animal = $query->param('animal');
51 my $log = $query->param('log');
52 my $res = $query->param('res');
53 my $conf = $query->param('conf');
54 my $branch = $query->param('branch');
55 my $changed_since_success = $query->param('changed_since_success');
56 my $changed_this_run = $query->param('changed_files');
57 my $log_archive = $query->param('logtar');
58 my $frozen_sconf = $query->param('frozen_sconf') || '';
59
60 my $brhandle;
61 if (open($brhandle,"../htdocs/branches_of_interest.txt"))
62 {
63     my @branches_of_interest = <$brhandle>;
64     close($brhandle);
65     chomp(@branches_of_interest);
66     unless (grep {$_ eq $branch} @branches_of_interest)
67     {
68         print
69             "Status: 492 bad branch parameter $branch\nContent-Type: text/plain\n\n",
70             "bad branch parameter $branch\n";
71         exit;   
72     }
73 }
74
75
76 my $content = 
77         "branch=$branch&res=$res&stage=$stage&animal=$animal&".
78         "ts=$ts&log=$log&conf=$conf";
79
80 my $extra_content = 
81         "changed_files=$changed_this_run&".
82         "changed_since_success=$changed_since_success&";
83
84 unless ($animal && $ts && $stage && $sig)
85 {
86         print 
87             "Status: 490 bad parameters\nContent-Type: text/plain\n\n",
88             "bad parameters for request\n";
89         exit;
90         
91 }
92
93 unless ($branch =~ /^(HEAD|REL\d+_\d+_STABLE)$/)
94 {
95         print
96             "Status: 492 bad branch parameter $branch\nContent-Type: text/plain\n\n",
97             "bad branch parameter $branch\n";
98         exit;
99
100 }
101
102
103 my $db = DBI->connect($dsn,$dbuser,$dbpass);
104
105 die $DBI::errstr unless $db;
106
107 my $gethost=
108     "select secret from buildsystems where name = ? and status = 'approved'";
109 my $sth = $db->prepare($gethost);
110 $sth->execute($animal);
111 my ($secret)=$sth->fetchrow_array();
112 $sth->finish;
113
114 my $tsdiff = time - $ts;
115
116 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($ts);
117 $year += 1900; $mon +=1;
118 my $date=
119     sprintf("%d-%.2d-%.2d_%.2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec);
120
121 if ($ENV{BF_DEBUG} || ($ts > time) || ($ts + 86400 < time ) || (! $secret) )
122 {
123     open(TX,">$buildlogs/$animal.$date");
124     print TX "sig=$sig\nlogtar-len=" , length($log_archive),
125         "\nstatus=$res\nstage=$stage\nconf:\n$conf\n",
126         "tsdiff:$tsdiff\n",
127         "changed_this_run:\n$changed_this_run\n",
128         "changed_since_success:\n$changed_since_success\n",
129         "frozen_sconf:$frozen_sconf\n",
130         "log:\n",$log;
131 #    $query->save(\*TX);
132     close(TX);
133 }
134
135 unless ($ts < time + 120)
136 {
137     my $gmt = gmtime($ts);
138     print "Status: 491 bad ts parameter - $ts ($gmt GMT) is in the future.\n",
139     "Content-Type: text/plain\n\n bad ts parameter - $ts ($gmt GMT) is in the future\n";
140         $db->disconnect;
141     exit;
142 }
143
144 unless ($ts + 86400 > time)
145 {
146     my $gmt = gmtime($ts);
147     print "Status: 491 bad ts parameter - $ts ($gmt GMT) is more than 24 hours ago.\n",
148      "Content-Type: text/plain\n\n bad ts parameter - $ts ($gmt GMT) is more than 24 hours ago.\n";
149     $db->disconnect;
150     exit;
151 }
152
153 unless ($secret)
154 {
155         print 
156             "Status: 495 Unknown System\nContent-Type: text/plain\n\n",
157             "System $animal is unknown\n";
158         $db->disconnect;
159         exit;
160         
161 }
162
163
164
165
166 my $calc_sig = sha1_hex($content,$secret);
167 my $calc_sig2 = sha1_hex($extra_content,$content,$secret);
168
169 if ($calc_sig ne $sig && $calc_sig2 ne $sig)
170 {
171
172         print "Status: 450 sig mismatch\nContent-Type: text/plain\n\n";
173         print "$sig mismatches $calc_sig($calc_sig2) on content:\n$content";
174         $db->disconnect;
175         exit;
176 }
177
178 # undo escape-proofing of base64 data and decode it
179 map {tr/$@/+=/; $_ = decode_base64($_); } 
180     ($log, $conf,$changed_this_run,$changed_since_success,$log_archive, $frozen_sconf);
181
182 if ($log =~/Last file mtime in snapshot: (.*)/)
183 {
184     my $snaptime = parsedate($1);
185     my $brch = $branch eq 'HEAD' ? 'master' : $branch;
186     my $last_branch_time = time - (30 * 86400);
187     $last_branch_time = `TZ=UTC GIT_DIR=$local_git_clone git log -1 --pretty=format:\%ct  $brch`;
188     if ($snaptime < ($last_branch_time - 86400))
189     {
190         print "Status: 493 snapshot too old: $1\nContent-Type: text/plain\n\n";
191         print "snapshot to old: $1\n";
192         $db->disconnect;
193         exit;   
194     }
195 }
196
197 ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($ts);
198 $year += 1900; $mon +=1;
199 my $dbdate=
200     sprintf("%d-%.2d-%.2d %.2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec);
201
202 my $log_file_names;
203 my @log_file_names;
204 my $dirname = "$buildlogs/tmp.$$.unpacklogs";
205
206 my $githeadref;
207
208 if ($log_archive)
209 {
210     my $log_handle;
211     my $archname = "$buildlogs/tmp.$$.tgz";
212     open($log_handle,">$archname");
213     binmode $log_handle;
214     print $log_handle $log_archive;
215     close $log_handle;
216     mkdir $dirname;
217     @log_file_names = `tar -z -C $dirname -xvf $archname 2>/dev/null`;
218     map {s/\s+//g; } @log_file_names;
219     my @qnames = grep { $_ ne 'githead.log' } @log_file_names;
220     map { $_ = qq("$_"); } @qnames;
221     $log_file_names = '{' . join(',',@qnames) . '}';
222     if (-e "$dirname/githead.log" )
223     {
224         open(my $githead,"$dirname/githead.log");
225         $githeadref = <$githead>;
226         chomp $githeadref;
227         close $githead;
228     }
229     # unlink $archname;
230 }
231
232 my $config_flags;
233 my $client_conf;
234 if ($frozen_sconf)
235 {
236     $client_conf = thaw $frozen_sconf;
237 }
238
239 if ($min_script_version)
240 {
241         $client_conf->{script_version} ||= '0.0';
242         my $cli_ver = $client_conf->{script_version} ;
243         $cli_ver =~ s/^REL_//;
244         my ($minmajor,$minminor) = split(/\./,$min_script_version);
245         my ($smajor,$sminor) = split(/\./,$cli_ver);
246         if ($minmajor > $smajor || ($minmajor == $smajor && $minminor > $sminor))
247         {
248                 print "Status: 460 script version too low\nContent-Type: text/plain\n\n";
249                 print 
250                         "Script version is below minimum required\n",
251                         "Reported version: $client_conf->{script_version},",
252                         "Minumum version required: $min_script_version\n";
253                 $db->disconnect;
254                 exit;
255         }
256 }
257
258 if ($min_web_script_version)
259 {
260         $client_conf->{web_script_version} ||= '0.0';
261         my $cli_ver = $client_conf->{web_script_version} ;
262         $cli_ver =~ s/^REL_//;
263         my ($minmajor,$minminor) = split(/\./,$min_web_script_version);
264         my ($smajor,$sminor) = split(/\./,$cli_ver);
265         if ($minmajor > $smajor || ($minmajor == $smajor && $minminor > $sminor))
266         {
267                 print "Status: 461 web script version too low\nContent-Type: text/plain\n\n";
268                 print 
269                         "Web Script version is below minimum required\n",
270                         "Reported version: $client_conf->{web_script_version}, ",
271                         "Minumum version required: $min_web_script_version\n"
272                         ;
273                 $db->disconnect;
274                 exit;
275         }
276 }
277
278 my @config_flags;
279 if (not exists $client_conf->{config_opts} )
280 {
281         @config_flags = ();
282 }
283 elsif (ref $client_conf->{config_opts} eq 'HASH')
284 {
285         # leave out keys with false values
286         @config_flags = grep { $client_conf->{config_opts}->{$_} } 
287             keys %{$client_conf->{config_opts}};
288 }
289 elsif (ref $client_conf->{config_opts} eq 'ARRAY' )
290 {
291         @config_flags = @{$client_conf->{config_opts}};
292 }
293
294 if (@config_flags)
295 {
296     @config_flags = grep {! m/=/ } @config_flags;
297     map {s/\s+//g; $_=qq("$_"); } @config_flags;
298     push @config_flags,'git' if $client_conf->{scm} eq 'git';
299     $config_flags = '{' . join(',',@config_flags) . '}' ;
300 }
301
302 my $scm = $client_conf->{scm} || 'cvs';
303 my $scmurl = $client_conf->{scm_url};
304
305 my $logst = <<EOSQL;
306     insert into build_status 
307       (sysname, snapshot,status, stage, log,conf_sum, branch,
308        changed_this_run, changed_since_success, 
309        log_archive_filenames , log_archive, build_flags, scm, scmurl, 
310        git_head_ref,frozen_conf)
311     values(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
312 EOSQL
313 ;
314
315
316 # this transaction lets us set log_error_verbosity to terse
317 # just for the duration of the transaction. That turns off logging the
318 # bind params, so all the logs don't get stuffed on the postgres logs
319
320
321 my $sqlres;
322 $db->begin_work;
323 $db->do("select set_local_error_terse()");
324
325
326 $sth=$db->prepare($logst);
327
328 $sth->bind_param(1,$animal);
329 $sth->bind_param(2,$dbdate);
330 $sth->bind_param(3,$res & 0x8fffffff); # in case we get a 64 bit int status!
331 $sth->bind_param(4,$stage);
332 $sth->bind_param(5,$log);
333 $sth->bind_param(6,$conf);
334 $sth->bind_param(7,$branch);
335 $sth->bind_param(8,$changed_this_run);
336 $sth->bind_param(9,$changed_since_success);
337 $sth->bind_param(10,$log_file_names);
338 #$sth->bind_param(11,$log_archive,{ pg_type => DBD::mysql::PG_BYTEA });
339 $sth->bind_param(11,undef,{ pg_type => DBD::mysql::PG_BYTEA });
340 $sth->bind_param(12,$config_flags);
341 $sth->bind_param(13,$scm);
342 $sth->bind_param(14,$scmurl);
343 $sth->bind_param(15,$githeadref);
344 $sth->bind_param(16,$frozen_sconf,{ pg_type => DBD::mysql::PG_BYTEA });
345
346 $sqlres = $sth->execute;
347
348 if ($sqlres)
349 {
350
351         $sth->finish;
352
353         my $logst2 = q{
354
355           insert into build_status_log 
356                 (sysname, snapshot, branch, log_stage, log_text, stage_duration)
357                 values (?, ?, ?, ?, ?, ?)
358
359     };
360
361         $sth = $db->prepare($logst2);
362
363         $/=undef;
364
365         my $stage_start = $ts;
366
367         foreach my $log_file( @log_file_names )
368         {
369                 next if $log_file =~ /^githead/;
370                 my $handle;
371                 open($handle,"$dirname/$log_file");
372                 my $mtime = (stat $handle)[9];
373                 my $stage_interval = $mtime - $stage_start;
374                 $stage_start = $mtime;
375                 my $ltext = <$handle>;
376                 close($handle);
377                 $ltext =~ s/\x00/\\0/g;
378                 $sqlres = $sth->execute($animal,$dbdate,$branch,$log_file,$ltext, 
379                           "$stage_interval seconds");
380                 last unless $sqlres;
381         }
382
383         $sth->finish unless $sqlres;
384
385 }
386
387 if (! $sqlres)
388 {
389
390         print "Status: 462 database failure\nContent-Type: text/plain\n\n";
391         print "Your report generated a database failure:\n", 
392                $db->errstr, 
393                          "\n";
394         $db->rollback;
395         $db->disconnect;
396         exit;
397 }
398
399
400 $db->commit;
401
402 my $prevst = <<EOSQL;
403
404   select coalesce((select distinct on (snapshot) stage
405                   from build_status
406                   where sysname = ? and branch = ? and snapshot < ?
407                   order by snapshot desc
408                   limit 1), 'NEW') as prev_status
409   
410 EOSQL
411
412 $sth=$db->prepare($prevst);
413 $sth->execute($animal,$branch,$dbdate);
414 my $row=$sth->fetchrow_arrayref;
415 my $prev_stat=$row->[0];
416 $sth->finish;
417
418 my $det_st = <<EOS;
419
420           select operating_system|| ' / ' || os_version as os , 
421                  compiler || ' / ' || compiler_version as compiler, 
422                  architecture as arch
423           from buildsystems 
424           where status = 'approved'
425                 and name = ?
426
427 EOS
428 ;
429 $sth=$db->prepare($det_st);
430 $sth->execute($animal);
431 $row=$sth->fetchrow_arrayref;
432 my ($os, $compiler,$arch) = @$row;
433 $sth->finish;
434
435 $db->begin_work;
436 # prevent occasional duplication by forcing serialization of this operation
437 $db->do("lock table dashboard_mat in share row exclusive mode");
438 $db->do("delete from dashboard_mat");
439 $db->do("insert into dashboard_mat select * from dashboard_mat_data");
440 $db->commit;
441
442 if ($stage ne 'OK')
443 {
444         $db->begin_work;
445         # prevent occasional duplication by forcing serialization of this operation
446         $db->do("lock table nrecent_failures in share row exclusive mode");
447         $db->do("delete from nrecent_failures");
448         $db->do("insert into nrecent_failures select bs.sysname, bs.snapshot, bs.branch from build_status bs where bs.stage <> 'OK' and bs.snapshot > now() - interval '90 days'");
449         $db->commit;
450 }
451
452 $db->disconnect;
453
454 print "Content-Type: text/plain\n\n";
455 print "request was on:\n";
456 print "res=$res&stage=$stage&animal=$animal&ts=$ts";
457
458 my $client_events = $client_conf->{mail_events};
459
460 if ($ENV{BF_DEBUG})
461 {
462         my $client_time = $client_conf->{current_ts};
463     open(TX,">>$buildlogs/$animal.$date");
464     print TX "\n",Dumper(\$client_conf),"\n";
465         print TX "server time: $server_time, client time: $client_time\n" if $client_time;
466     close(TX);
467 }
468
469 my $bcc_stat = [];
470 my $bcc_chg=[];
471 if (ref $client_events)
472 {
473     my $cbcc = $client_events->{all};
474     if (ref $cbcc)
475     {
476         push @$bcc_stat, @$cbcc;
477     }
478     elsif (defined $cbcc)
479     {
480         push @$bcc_stat, $cbcc;
481     }
482     if ($stage ne 'OK')
483     {
484         $cbcc = $client_events->{all};
485         if (ref $cbcc)
486         {
487             push @$bcc_stat, @$cbcc;
488         }
489         elsif (defined $cbcc)
490         {
491             push @$bcc_stat, $cbcc;
492         }
493     }
494     $cbcc = $client_events->{change};
495     if (ref $cbcc)
496     {
497         push @$bcc_chg, @$cbcc;
498     }
499     elsif (defined $cbcc)
500     {
501         push @$bcc_chg, $cbcc;
502     }
503     if ($stage eq 'OK' || $prev_stat eq 'OK')
504     {
505         $cbcc = $client_events->{green};
506         if (ref $cbcc)
507         {
508             push @$bcc_chg, @$cbcc;
509         }
510         elsif (defined $cbcc)
511         {
512             push @$bcc_chg, $cbcc;
513         }
514     }
515 }
516
517
518 my $url = $query->url(-base => 1);
519
520
521 my $stat_type = $stage eq 'OK' ? 'Status' : 'Failed at Stage';
522
523 my $mailto = [@$all_stat];
524 push(@$mailto,@$fail_stat) if $stage ne 'OK';
525
526 my $me = `id -un`; chomp($me);
527
528 my $host = `hostname`; chomp ($host);
529 $host = $default_host unless ($host =~ m/[.]/ || !defined($default_host));
530
531 my $from_addr = "PG Build Farm <$me\@$host>";
532 $from_addr =~ tr /\r\n//d;
533
534 my $msg = new Mail::Send;
535
536
537 $msg->to(@$mailto);
538 $msg->bcc(@$bcc_stat) if (@$bcc_stat);
539 $msg->subject("PGBuildfarm member $animal Branch $branch $stat_type $stage");
540 $msg->set('From',$from_addr);
541 my $fh = $msg->open;
542 print $fh <<EOMAIL; 
543
544
545 The PGBuildfarm member $animal had the following event on branch $branch:
546
547 $stat_type: $stage
548
549 The snapshot timestamp for the build that triggered this notification is: $dbdate
550
551 The specs of this machine are:
552 OS:  $os
553 Arch: $arch
554 Comp: $compiler
555
556 For more information, see $url/cgi-bin/show_history.pl?nm=$animal&br=$branch
557
558 EOMAIL
559
560 $fh->close;
561
562 exit if ($stage eq $prev_stat);
563
564 $mailto = [@$change_stat];
565 push(@$mailto,@$green_stat) if ($stage eq 'OK' || $prev_stat eq 'OK');
566
567 $msg = new Mail::Send;
568
569
570 $msg->to(@$mailto);
571 $msg->bcc(@$bcc_chg) if (@$bcc_chg);
572
573 $stat_type = $prev_stat ne 'OK' ? "changed from $prev_stat failure to $stage" :
574     "changed from OK to $stage";
575 $stat_type = "New member: $stage" if $prev_stat eq 'NEW';
576 $stat_type .= " failure" if $stage ne 'OK';
577
578 $msg->subject("PGBuildfarm member $animal Branch $branch Status $stat_type");
579 $msg->set('From',$from_addr);
580 $fh = $msg->open;
581 print $fh <<EOMAIL;
582
583 The PGBuildfarm member $animal had the following event on branch $branch:
584
585 Status $stat_type
586
587 The snapshot timestamp for the build that triggered this notification is: $dbdate
588
589 The specs of this machine are:
590 OS:  $os
591 Arch: $arch
592 Comp: $compiler
593
594 For more information, see $url/cgi-bin/show_history.pl?nm=$animal&br=$branch
595
596 EOMAIL
597
598 $fh->close;