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