Include slot owner in summary hash
[fateserver.git] / index.cgi
1 #! /usr/bin/perl
2 #
3 # Copyright (c) 2011 Mans Rullgard <mans@mansr.com>
4 # Copyright (c) 2014 Tiancheng "Timothy" Gu <timothygu99@gmail.com>
5 #
6 # Permission to use, copy, modify, and distribute this software for any
7 # purpose with or without fee is hereby granted, provided that the above
8 # copyright notice and this permission notice appear in all copies.
9 #
10 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHORS DISCLAIM ALL WARRANTIES
11 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
13 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
18 use strict;
19 use warnings;
20
21 use CGI qw/param/;
22 use HTML::Entities;
23 use FATE;
24 use Time::Zone;
25 use URI::Escape;
26
27 # Format for /?query= : /?query=type:value//type:value// (URI encoded).
28 # Trailing // does not matter (i.e. may be added).
29 # @queries contains an array of 'type:value' strings.
30 # Every member of @queries can be further parsed with another simple
31 # split(/:/, $this_query, 2);
32 my @queries = split(/\/\//, uri_unescape param 'query') if (param 'query');
33
34 my $sort = param('sort');
35 $sort =~ s/[^A-Za-z0-9 ]*//g;
36 param('sort', $sort);
37 $sort    = $sort eq 'arch' ? 'subarch': $sort;
38
39 (my $uri = $ENV{REQUEST_URI}) =~ s/\?.*//;
40
41 opendir D, $fatedir or fail 'Server error: $fatedir not found';
42 my @slots = grep /^[^.]/, readdir D;
43 closedir D;
44
45 my @reps;
46 my $allpass = 0;
47 my $allfail = 0;
48
49 for my $slot (@slots) {
50     next if -e "$fatedir/$slot/hidden";
51     my $rep = load_summary $slot, 'latest' or next;
52     next if time - parse_date($$rep{date}) > $hidden_age;
53
54     my $not_matched = 0;
55     $$rep{subarch} = $$rep{arch} if not $$rep{subarch};
56     for my $this_query (@queries) {
57         my ($type, $text) = split(/:/, $this_query, 2);
58         $not_matched = 1 if ($$rep{$type} ne $text);
59     }
60     next if $not_matched;
61
62     push @reps, $rep;
63     if ($$rep{npass} == $$rep{ntests} and !$$rep{status}) {
64         $allpass++;
65     } elsif ($$rep{npass} == 0) {
66         $allfail++;
67     }
68
69     if (my $prev = load_summary $slot, 'previous') {
70         my $pfail = $$prev{ntests} - $$prev{npass};
71         $$rep{alert} = $$rep{ntests} && $$rep{nfail} <=> $pfail;
72         $$rep{dwarn} = $$rep{nwarn} <=> $$prev{nwarn};
73         $$rep{pdate} = $$prev{date};
74     }
75 }
76
77 @reps or fail @queries ? 'No items matching search criteria. ' .
78                          "<a href=\"$uri\">Clear all search criteria.</a>" :
79                          'No data in $fatedir.';
80
81 $allpass = 100 * $allpass / @reps;
82 $allfail = 100 * $allfail / @reps;
83 my $warn = 100 - $allpass - $allfail;
84
85 my @sort = ('subarch', 'os', 'cc', 'comment', 'slot');
86 my $sdir = 1; # default to ascending sorting
87 defined $sort and unshift @sort, split /\/\//, $sort;
88 $sort ||= $sort[0];
89
90 sub nscmp {
91     my ($a, $b) = @_;
92     return int $a || int $b ? $a <=> $b : lc $a cmp lc $b;
93 }
94
95 sub repcmp {
96     my $r;
97     for my $s (@sort) {
98         if ($s =~ /^desc/) {
99             $s =~ s/^desc//;
100             $sdir = -1;
101         }
102         last if $r = $sdir * nscmp $$a{$s}, $$b{$s};
103     }
104     return $r;
105 };
106
107 sub lsort {
108     my $params = '';
109     for my $thisparam (param) {
110         next if $thisparam =~ 'sort';
111         $params .= '&' if $params ne '';
112         $params .= "$thisparam=" . param($thisparam);
113     }
114     $params .= '&' if $params;
115     my ($text, $key) = @_;
116
117     my $newkey = '';
118     if ($sort eq $key) {                           # $key     = $sort
119         for my $thiskey (split /\/\//, $key) {
120             if ($thiskey =~ /^desc/) {             # $thiskey = desc*
121                 $thiskey =~ s/^desc//;
122             } else {                               # $thiskey = *
123                 $thiskey = "desc$thiskey";
124             }
125             if ($newkey eq '') {
126                 $newkey = $thiskey;
127             } else {
128                 $newkey .= "//$thiskey";
129             }
130         }
131     }
132
133     $key = $newkey if $newkey ne '';
134     anchor $text, href => "$uri?${params}sort=$key";
135 }
136
137 sub category {
138     my ($category, $rep) = @_;
139     my $head_printed = 0;
140
141     # $params will contain parameters else than query, if any, in HTTP format.
142     my $params = '';
143     for my $thisparam (param) {
144         next if $thisparam eq 'query';
145         $params .= '&' if $params ne '';
146         $params .= "$thisparam=" . param($thisparam);
147     }
148     my $head = ($params ? '&' : '') . 'query=';
149
150     if (@queries) {
151         for my $this_query (@queries) {
152             my ($type, $text) = split(/:/, $this_query, 2);
153             if ($type ne $category) {
154                 $params .= $head if (!$head_printed);
155                 $params .= $this_query . '//';
156                 $head_printed = 1;
157             }
158         }
159     }
160     $params .= $head if (!$head_printed);
161     $params .= "$category:" . uri_escape_utf8 "$$rep{$category}" . '//';
162     $head_printed = 1;                 # for the sake of completeness
163
164     start 'td';
165     anchor $$rep{$category}, href => "$uri?$params";
166     end 'td';
167 }
168
169 print "Content-type: text/html\r\n";
170 print "Access-Control-Allow-Origin: https://ffmpeg.org\r\n";
171
172 if ($ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/) {
173     print "Content-Encoding: gzip\r\n\r\n";
174     open STDOUT, '|-', 'gzip';
175 } else {
176     print "\r\n";
177 }
178
179 head1;
180 print "<title>FATE</title>\n";
181 print <<EOF;
182 <script type="text/javascript">
183   function toggle(id, arr) {
184       var e = document.getElementById(id);
185       if (e.style.display == 'table-row') {
186           e.style.display = 'none';
187           arr.classList.remove("fa-caret-up");
188           arr.classList.add("fa-caret-down");
189       } else {
190           e.style.display = 'table-row';
191           arr.classList.add("fa-caret-up");
192           arr.classList.remove("fa-caret-down");
193       }
194   }
195 </script>
196 EOF
197 head2;
198 print "FATE\n";
199 head3;
200
201 if (@queries) {
202     start 'p';
203     print 'Search patterns: ';
204     for my $this_query (@queries) {
205         my ($type, $text) = split(/:/, $this_query, 2);
206         print "$type: $text; ";
207     }
208     anchor 'clear all.', href => "$uri";
209     end 'p';
210 }
211
212 start 'div', class => 'table-responsive';
213 start 'table', id => 'index', class => 'replist table';
214 start 'thead';
215 start 'tr';
216 start 'td', colspan => 8, id => 'failometer';
217 start 'div', class => 'progress';
218 if ($allpass) {
219     print <<EOF;
220 <div class="progress-bar pass" role="progressbar" title="${allpass}% tests passed" aria-valuenow="${allpass}" aria-valuemin="0" aria-valuemax="100" style="width: ${allpass}%">
221   <span class="sr-only">${allpass}%</span>
222 </div>
223 EOF
224 }
225 if ($warn) {
226     print <<EOF;
227 <div class="progress-bar warn" role="progressbar" title="${warn}% tests failed" aria-valuenow="${warn}" aria-valuemin="0" aria-valuemax="100" style="width: ${warn}%">
228   <span class="sr-only">${warn}%</span>
229 </div>
230 EOF
231 }
232 if ($allfail) {
233     print <<EOF;
234 <div class="progress-bar fail" role="progressbar" title="${allfail}% build failed" aria-valuenow="${allfail}" aria-valuemin="0" aria-valuemax="100" style="width: ${allfail}%">
235   <span class="sr-only">${allfail}%</span>
236 </div>
237 EOF
238 }
239 end 'div';
240 end 'td';
241 end 'tr';
242 start 'tr';
243 start 'th'; lsort 'Time',     'descdate';      end 'th';
244 start 'th'; lsort 'Rev',      'rev';           end 'th';
245 start 'th'; lsort 'Arch',     'arch';          end 'th';
246 start 'th'; lsort 'OS',       'os';            end 'th';
247 start 'th'; lsort 'Compiler', 'cc';            end 'th';
248 start 'th'; lsort 'Comment',  'comment';       end 'th';
249 start 'th'; lsort 'Warnings', 'nwarn';         end 'th';
250 start 'th'; lsort 'Tests',    'npass';         end 'th';
251 end 'tr';
252 end 'thead';
253 start 'tbody';
254 for my $rep (sort repcmp @reps) {
255     my $ntest = $$rep{ntests};
256     my $npass = $$rep{npass};
257     my $time = parse_date $$rep{date};
258     my $age  = time - tz_local_offset() - $time;
259     my $agestr = agestr $age, $time;
260     my $ageclass = '';
261     my $rtext;
262     my $rclass;
263     my $log;
264     my $alert = ('pass', '', 'warn')[$$rep{alert} + 1];
265     my $walert = ('pass', '', 'warn')[$$rep{dwarn} + 1];
266     (my $slotid = $$rep{slot}) =~ s/[^a-z0-9_-]/_/ig;
267
268     if ($age < $recent_age) {
269         $ageclass = 'recent';
270     } elsif ($age > $ancient_age) {
271         $ageclass = 'ancient';
272         $alert = '';
273     }
274
275     start 'tr', class => "$ageclass $alert";
276     start 'td';
277     anchor $agestr, href => href slot => $$rep{slot};
278     end 'td';
279     if ($gitweb and $$rep{rev} =~ /(N-)?(.*)/) {
280         start 'td';
281         anchor $$rep{rev}, href => "$gitweb;a=commit;h=$2";
282         end 'td';
283     } else {
284         td $$rep{rev};
285     }
286
287     category 'subarch', $rep;
288     category 'os', $rep;
289     category 'cc', $rep;
290     td $$rep{comment}, class => 'comment';
291     if ($npass) {
292         $rtext  = "$npass / $ntest";
293         $rclass = $npass==$ntest? 'pass' : $npass? 'warn' : 'fail';
294     } elsif (!$ntest and !$$rep{status}) {
295         $rtext  = "build only";
296         $rclass = $$rep{status}? 'fail' : 'pass';
297     } else {
298         $rtext  = $$rep{errstr};
299         $rclass = 'fail';
300         for my $base ('test', 'compile', 'configure') {
301             my $file = "$fatedir/$$rep{slot}/$$rep{date}/$base.log.gz";
302             if (-r $file) {
303                 $log = qx{zcat $file | tail -n20};
304                 last;
305             }
306         }
307     }
308     start 'td', class => "$walert";
309     start 'div', class => 'pull-left';
310     anchor $$rep{nwarn},
311         href => href slot => $$rep{slot}, time => $$rep{date}, log => 'compile';
312     end;
313     start 'div', class => 'pull-right';
314     anchor '±',
315         href => href slot => $$rep{slot}, time => $$rep{date},
316         log => "compile/$$rep{pdate}";
317     end;
318     end;
319     start 'td', class => "$rclass";
320     start 'div', class => 'pull-left';
321     anchor $rtext, href => href slot => $$rep{slot}, time => $$rep{date};
322     end;
323     if ($npass < $ntest or $log) {
324         start 'div', class => 'pull-right';
325         span '', class => 'toggle fa fa-caret-down', onclick => "toggle('$slotid', this)";
326         end;
327     }
328     end;
329     end 'tr';
330     print "\n";
331     if ($npass < $ntest && $ntest - $npass < 100) {
332         trowa { style => 'display: none' }, '';
333         print "\n";
334         my $report = load_report $$rep{slot}, $$rep{date};
335         my @fail = grep $$_{status} ne '0', @{$$report{recs}};
336         my $lastpass = load_lastpass $$rep{slot};
337
338         start 'tr', id => $slotid, class => 'slotfail';
339         start 'td', colspan => 8;
340         start 'table', class => 'minirep';
341         start 'thead';
342         start 'tr';
343         if ($$rep{nfail} eq 1) {
344             th "1 failed test";
345         } else {
346             th "$$rep{nfail} failed tests";
347         }
348         th 'Status', class => 'errcode';
349         end 'tr';
350         end 'thead';
351         start 'tbody';
352         for (sort { $$a{name} cmp $$b{name} } @fail) {
353             my $falert = $$rep{pdate} eq $$lastpass{$$_{name}}{date} ?
354               'warn' : '';
355             start 'tr', class => "$falert";
356             td $$_{name};
357             td $$_{status}, class => 'errcode';
358             end 'tr';
359         }
360         end 'tbody';
361         end 'table';
362         end 'td';
363         end 'tr';
364         print "\n";
365     } elsif ($log) {
366         trowa { style => 'display: none' }, '';
367         start 'tr', id => $slotid, class => 'slotfail';
368         start 'td', colspan => 8;
369         start 'pre', class => 'minilog';
370         print encode_entities($log, '<>&"');
371         end 'pre';
372         end 'td';
373         end 'tr';
374     }
375 }
376 end 'tbody';
377 end 'table';
378 end 'div';
379 footer;