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