57a60eddf23e3423f38968d59364852e5cc8ee90
[buildfarm-server.git] / cgi-bin / pgstatus.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::Pg;
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:Pg: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 $db->begin_work;
321 $db->do("select set_local_error_terse()");
322
323
324 $sth=$db->prepare($logst);
325
326 $sth->bind_param(1,$animal);
327 $sth->bind_param(2,$dbdate);
328 $sth->bind_param(3,$res);
329 $sth->bind_param(4,$stage);
330 $sth->bind_param(5,$log);
331 $sth->bind_param(6,$conf);
332 $sth->bind_param(7,$branch);
333 $sth->bind_param(8,$changed_this_run);
334 $sth->bind_param(9,$changed_since_success);
335 $sth->bind_param(10,$log_file_names);
336 #$sth->bind_param(11,$log_archive,{ pg_type => DBD::Pg::PG_BYTEA });
337 $sth->bind_param(11,undef,{ pg_type => DBD::Pg::PG_BYTEA });
338 $sth->bind_param(12,$config_flags);
339 $sth->bind_param(13,$scm);
340 $sth->bind_param(14,$scmurl);
341 $sth->bind_param(15,$githeadref);
342 $sth->bind_param(16,$frozen_sconf,{ pg_type => DBD::Pg::PG_BYTEA });
343
344 $sth->execute;
345 $sth->finish;
346
347
348
349 my $logst2 = <<EOSQL;
350
351   insert into build_status_log 
352     (sysname, snapshot, branch, log_stage, log_text, stage_duration)
353     values (?, ?, ?, ?, ?, ?)
354
355 EOSQL
356     ;
357
358 $sth = $db->prepare($logst2);
359
360 $/=undef;
361
362 my $stage_start = $ts;
363
364 foreach my $log_file( @log_file_names )
365 {
366     next if $log_file =~ /^githead/;
367     my $handle;
368     open($handle,"$dirname/$log_file");
369     my $mtime = (stat $handle)[9];
370     my $stage_interval = $mtime - $stage_start;
371     $stage_start = $mtime;
372     my $ltext = <$handle>;
373     close($handle);
374     $ltext =~ s/\x00/\\0/g;
375     $sth->execute($animal,$dbdate,$branch,$log_file,$ltext, 
376                   "$stage_interval seconds");
377 }
378
379 $sth->finish;
380
381 $db->commit;
382
383 my $prevst = <<EOSQL;
384
385   select coalesce((select distinct on (snapshot) stage
386                   from build_status
387                   where sysname = ? and branch = ? and snapshot < ?
388                   order by snapshot desc
389                   limit 1), 'NEW') as prev_status
390   
391 EOSQL
392
393 $sth=$db->prepare($prevst);
394 $sth->execute($animal,$branch,$dbdate);
395 my $row=$sth->fetchrow_arrayref;
396 my $prev_stat=$row->[0];
397 $sth->finish;
398
399 my $det_st = <<EOS;
400
401           select operating_system|| ' / ' || os_version as os , 
402                  compiler || ' / ' || compiler_version as compiler, 
403                  architecture as arch
404           from buildsystems 
405           where status = 'approved'
406                 and name = ?
407
408 EOS
409 ;
410 $sth=$db->prepare($det_st);
411 $sth->execute($animal);
412 $row=$sth->fetchrow_arrayref;
413 my ($os, $compiler,$arch) = @$row;
414 $sth->finish;
415
416 $db->begin_work;
417 # prevent occasional duplication by forcing serialization of this operation
418 $db->do("lock table dashboard_mat in share row exclusive mode");
419 $db->do("delete from dashboard_mat");
420 $db->do("insert into dashboard_mat select * from dashboard_mat_data");
421 $db->commit;
422
423 if ($stage ne 'OK')
424 {
425         $db->begin_work;
426         # prevent occasional duplication by forcing serialization of this operation
427         $db->do("lock table nrecent_failures in share row exclusive mode");
428         $db->do("delete from nrecent_failures");
429         $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'");
430         $db->commit;
431 }
432
433 $db->disconnect;
434
435 print "Content-Type: text/plain\n\n";
436 print "request was on:\n";
437 print "res=$res&stage=$stage&animal=$animal&ts=$ts";
438
439 my $client_events = $client_conf->{mail_events};
440
441 if ($ENV{BF_DEBUG})
442 {
443         my $client_time = $client_conf->{current_ts};
444     open(TX,">>$buildlogs/$animal.$date");
445     print TX "\n",Dumper(\$client_conf),"\n";
446         print TX "server time: $server_time, client time: $client_time\n" if $client_time;
447     close(TX);
448 }
449
450 my $bcc_stat = [];
451 my $bcc_chg=[];
452 if (ref $client_events)
453 {
454     my $cbcc = $client_events->{all};
455     if (ref $cbcc)
456     {
457         push @$bcc_stat, @$cbcc;
458     }
459     elsif (defined $cbcc)
460     {
461         push @$bcc_stat, $cbcc;
462     }
463     if ($stage ne 'OK')
464     {
465         $cbcc = $client_events->{all};
466         if (ref $cbcc)
467         {
468             push @$bcc_stat, @$cbcc;
469         }
470         elsif (defined $cbcc)
471         {
472             push @$bcc_stat, $cbcc;
473         }
474     }
475     $cbcc = $client_events->{change};
476     if (ref $cbcc)
477     {
478         push @$bcc_chg, @$cbcc;
479     }
480     elsif (defined $cbcc)
481     {
482         push @$bcc_chg, $cbcc;
483     }
484     if ($stage eq 'OK' || $prev_stat eq 'OK')
485     {
486         $cbcc = $client_events->{green};
487         if (ref $cbcc)
488         {
489             push @$bcc_chg, @$cbcc;
490         }
491         elsif (defined $cbcc)
492         {
493             push @$bcc_chg, $cbcc;
494         }
495     }
496 }
497
498
499 my $url = $query->url(-base => 1);
500
501
502 my $stat_type = $stage eq 'OK' ? 'Status' : 'Failed at Stage';
503
504 my $mailto = [@$all_stat];
505 push(@$mailto,@$fail_stat) if $stage ne 'OK';
506
507 my $me = `id -un`; chomp($me);
508
509 my $host = `hostname`; chomp ($host);
510 $host = $default_host unless ($host =~ m/[.]/ || !defined($default_host));
511
512 my $from_addr = "PG Build Farm <$me\@$host>";
513 $from_addr =~ tr /\r\n//d;
514
515 my $msg = new Mail::Send;
516
517
518 $msg->to(@$mailto);
519 $msg->bcc(@$bcc_stat) if (@$bcc_stat);
520 $msg->subject("PGBuildfarm member $animal Branch $branch $stat_type $stage");
521 $msg->set('From',$from_addr);
522 my $fh = $msg->open;
523 print $fh <<EOMAIL; 
524
525
526 The PGBuildfarm member $animal had the following event on branch $branch:
527
528 $stat_type: $stage
529
530 The snapshot timestamp for the build that triggered this notification is: $dbdate
531
532 The specs of this machine are:
533 OS:  $os
534 Arch: $arch
535 Comp: $compiler
536
537 For more information, see $url/cgi-bin/show_history.pl?nm=$animal&br=$branch
538
539 EOMAIL
540
541 $fh->close;
542
543 exit if ($stage eq $prev_stat);
544
545 $mailto = [@$change_stat];
546 push(@$mailto,@$green_stat) if ($stage eq 'OK' || $prev_stat eq 'OK');
547
548 $msg = new Mail::Send;
549
550
551 $msg->to(@$mailto);
552 $msg->bcc(@$bcc_chg) if (@$bcc_chg);
553
554 $stat_type = $prev_stat ne 'OK' ? "changed from $prev_stat failure to $stage" :
555     "changed from OK to $stage";
556 $stat_type = "New member: $stage" if $prev_stat eq 'NEW';
557 $stat_type .= " failure" if $stage ne 'OK';
558
559 $msg->subject("PGBuildfarm member $animal Branch $branch Status $stat_type");
560 $msg->set('From',$from_addr);
561 $fh = $msg->open;
562 print $fh <<EOMAIL;
563
564 The PGBuildfarm member $animal had the following event on branch $branch:
565
566 Status $stat_type
567
568 The snapshot timestamp for the build that triggered this notification is: $dbdate
569
570 The specs of this machine are:
571 OS:  $os
572 Arch: $arch
573 Comp: $compiler
574
575 For more information, see $url/cgi-bin/show_history.pl?nm=$animal&br=$branch
576
577 EOMAIL
578
579 $fh->close;