Update to new website style
[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    = $sort eq 'arch' ? 'subarch': $sort;
36
37 (my $uri = $ENV{REQUEST_URI}) =~ s/\?.*//;
38
39 opendir D, $fatedir or fail 'Server error: $fatedir not found';
40 my @slots = grep /^[^.]/, readdir D;
41 closedir D;
42
43 my @reps;
44 my $allpass = 0;
45 my $allfail = 0;
46
47 for my $slot (@slots) {
48     next if -e "$fatedir/$slot/hidden";
49     my $rep = load_summary $slot, 'latest' or next;
50     next if time - parse_date($$rep{date}) > $hidden_age;
51
52     my $not_matched = 0;
53     $$rep{subarch} = $$rep{arch} if not $$rep{subarch};
54     for my $this_query (@queries) {
55         my ($type, $text) = split(/:/, $this_query, 2);
56         $not_matched = 1 if ($$rep{$type} ne $text);
57     }
58     next if $not_matched;
59
60     push @reps, $rep;
61     if ($$rep{npass} == $$rep{ntests} and !$$rep{status}) {
62         $allpass++;
63     } elsif ($$rep{npass} == 0) {
64         $allfail++;
65     }
66
67     if (my $prev = load_summary $slot, 'previous') {
68         my $pfail = $$prev{ntests} - $$prev{npass};
69         $$rep{alert} = $$rep{ntests} && $$rep{nfail} <=> $pfail;
70         $$rep{dwarn} = $$rep{nwarn} <=> $$prev{nwarn};
71         $$rep{pdate} = $$prev{date};
72     }
73 }
74
75 @reps or fail @queries ? 'No items matching search criteria. ' .
76                          "<a href=\"$uri\">Clear all search criteria.</a>" :
77                          'No data in $fatedir.';
78
79 $allpass = 100 * $allpass / @reps;
80 $allfail = 100 * $allfail / @reps;
81 my $warn = 100 - $allpass - $allfail;
82
83 my @sort = ('subarch', 'os', 'cc', 'comment', 'slot');
84 my $sdir = 1; # default to ascending sorting
85 defined $sort and unshift @sort, split /\/\//, $sort;
86 $sort ||= $sort[0];
87
88 sub nscmp {
89     my ($a, $b) = @_;
90     return int $a || int $b ? $a <=> $b : lc $a cmp lc $b;
91 }
92
93 sub repcmp {
94     my $r;
95     for my $s (@sort) {
96         if ($s =~ /^desc/) {
97             $s =~ s/^desc//;
98             $sdir = -1;
99         }
100         last if $r = $sdir * nscmp $$a{$s}, $$b{$s};
101     }
102     return $r;
103 };
104
105 sub lsort {
106     my $params = '';
107     for my $thisparam (param) {
108         next if $thisparam =~ 'sort';
109         $params .= '&' if $params ne '';
110         $params .= "$thisparam=" . param($thisparam);
111     }
112     $params .= '&' if $params;
113     my ($text, $key) = @_;
114
115     my $newkey = '';
116     if ($sort eq $key) {                           # $key     = $sort
117         for my $thiskey (split /\/\//, $key) {
118             if ($thiskey =~ /^desc/) {             # $thiskey = desc*
119                 $thiskey =~ s/^desc//;
120             } else {                               # $thiskey = *
121                 $thiskey = "desc$thiskey";
122             }
123             if ($newkey eq '') {
124                 $newkey = $thiskey;
125             } else {
126                 $newkey .= "//$thiskey";
127             }
128         }
129     }
130
131     $key = $newkey if $newkey ne '';
132     anchor $text, href => "$uri?${params}sort=$key";
133 }
134
135 sub category {
136     my ($category, $rep) = @_;
137     my $head_printed = 0;
138
139     # $params will contain parameters else than query, if any, in HTTP format.
140     my $params = '';
141     for my $thisparam (param) {
142         next if $thisparam eq 'query';
143         $params .= '&' if $params ne '';
144         $params .= "$thisparam=" . param($thisparam);
145     }
146     my $head = ($params ? '&' : '') . 'query=';
147
148     if (@queries) {
149         for my $this_query (@queries) {
150             my ($type, $text) = split(/:/, $this_query, 2);
151             if ($type ne $category) {
152                 $params .= $head if (!$head_printed);
153                 $params .= $this_query . '//';
154                 $head_printed = 1;
155             }
156         }
157     }
158     $params .= $head if (!$head_printed);
159     $params .= "$category:" . uri_escape_utf8 "$$rep{$category}" . '//';
160     $head_printed = 1;                 # for the sake of completeness
161
162     start 'td';
163     anchor $$rep{$category}, href => "$uri?$params";
164     end 'td';
165 }
166
167 print "Content-type: text/html\r\n";
168 print "Access-Control-Allow-Origin: https://ffmpeg.org\r\n";
169
170 if ($ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/) {
171     print "Content-Encoding: gzip\r\n\r\n";
172     open STDOUT, '|-', 'gzip';
173 } else {
174     print "\r\n";
175 }
176
177 head1;
178 print "<title>FATE</title>\n";
179 print <<EOF;
180 <script type="text/javascript">
181   function toggle(id, arr) {
182       var e = document.getElementById(id);
183       if (e.style.display == 'table-row') {
184           e.style.display = 'none';
185           arr.classList.remove("fa-caret-up");
186           arr.classList.add("fa-caret-down");
187       } else {
188           e.style.display = 'table-row';
189           arr.classList.add("fa-caret-up");
190           arr.classList.remove("fa-caret-down");
191       }
192   }
193 </script>
194 EOF
195 head2;
196 print "FATE\n";
197 head3;
198
199 if (@queries) {
200     start 'p';
201     print 'Search patterns: ';
202     for my $this_query (@queries) {
203         my ($type, $text) = split(/:/, $this_query, 2);
204         print "$type: $text; ";
205     }
206     anchor 'clear all.', href => "$uri";
207     end 'p';
208 }
209
210 start 'div', class => 'table-responsive';
211 start 'table', id => 'index', class => 'replist table';
212 start 'thead';
213 start 'tr';
214 start 'td', colspan => 8, id => 'failometer';
215 start 'div', class => 'progress';
216 if ($allpass) {
217     print <<EOF;
218 <div class="progress-bar pass" role="progressbar" title="${allpass}% tests passed" aria-valuenow="${allpass}" aria-valuemin="0" aria-valuemax="100" style="width: ${allpass}%">
219   <span class="sr-only">${allpass}%}</span>
220 </div>
221 EOF
222 }
223 if ($warn) {
224     print <<EOF;
225 <div class="progress-bar warn" role="progressbar" title="${warn}% tests failed" aria-valuenow="${warn}" aria-valuemin="0" aria-valuemax="100" style="width: ${warn}%">
226   <span class="sr-only">${warn}%</span>
227 </div>
228 EOF
229 }
230 if ($allfail) {
231     print <<EOF;
232 <div class="progress-bar fail" role="progressbar" title="${allfail}% build failed" aria-valuenow="${allfail}" aria-valuemin="0" aria-valuemax="100" style="width: ${allfail}%">
233   <span class="sr-only">${allfail}%</span>
234 </div>
235 EOF
236 }
237 end 'div';
238 end 'td';
239 end 'tr';
240 start 'tr';
241 start 'th'; lsort 'Time',     'descdate';      end 'th';
242 start 'th'; lsort 'Rev',      'rev';           end 'th';
243 start 'th'; lsort 'Arch',     'arch';          end 'th';
244 start 'th'; lsort 'OS',       'os';            end 'th';
245 start 'th'; lsort 'Compiler', 'cc';            end 'th';
246 start 'th'; lsort 'Comment',  'comment';       end 'th';
247 start 'th'; lsort 'Warnings', 'nwarn';         end 'th';
248 start 'th'; lsort 'Tests',    'npass';         end 'th';
249 end 'tr';
250 end 'thead';
251 start 'tbody';
252 for my $rep (sort repcmp @reps) {
253     my $ntest = $$rep{ntests};
254     my $npass = $$rep{npass};
255     my $time = parse_date $$rep{date};
256     my $age  = time - tz_local_offset() - $time;
257     my $agestr = agestr $age, $time;
258     my $ageclass = '';
259     my $rtext;
260     my $rclass;
261     my $log;
262     my $alert = ('pass', '', 'warn')[$$rep{alert} + 1];
263     my $walert = ('pass', '', 'warn')[$$rep{dwarn} + 1];
264     (my $slotid = $$rep{slot}) =~ s/[^a-z0-9_-]/_/ig;
265
266     if ($age < $recent_age) {
267         $ageclass = 'recent';
268     } elsif ($age > $ancient_age) {
269         $ageclass = 'ancient';
270         $alert = '';
271     }
272
273     start 'tr', class => "$ageclass $alert";
274     start 'td';
275     anchor $agestr, href => href slot => $$rep{slot};
276     end 'td';
277     if ($gitweb and $$rep{rev} =~ /(N-)?(.*)/) {
278         start 'td';
279         anchor $$rep{rev}, href => "$gitweb;a=commit;h=$2";
280         end 'td';
281     } else {
282         td $$rep{rev};
283     }
284
285     category 'subarch', $rep;
286     category 'os', $rep;
287     category 'cc', $rep;
288     td $$rep{comment}, class => 'comment';
289     if ($npass) {
290         $rtext  = "$npass / $ntest";
291         $rclass = $npass==$ntest? 'pass' : $npass? 'warn' : 'fail';
292     } elsif (!$ntest and !$$rep{status}) {
293         $rtext  = "build only";
294         $rclass = $$rep{status}? 'fail' : 'pass';
295     } else {
296         $rtext  = $$rep{errstr};
297         $rclass = 'fail';
298         for my $base ('test', 'compile', 'configure') {
299             my $file = "$fatedir/$$rep{slot}/$$rep{date}/$base.log.gz";
300             if (-r $file) {
301                 $log = qx{zcat $file | tail -n20};
302                 last;
303             }
304         }
305     }
306     start 'td', class => "$walert";
307     start 'div', class => 'pull-left';
308     anchor $$rep{nwarn},
309         href => href slot => $$rep{slot}, time => $$rep{date}, log => 'compile';
310     end;
311     start 'div', class => 'pull-right';
312     anchor '±',
313         href => href slot => $$rep{slot}, time => $$rep{date},
314         log => "compile/$$rep{pdate}";
315     end;
316     end;
317     start 'td', class => "$rclass";
318     start 'div', class => 'pull-left';
319     anchor $rtext, href => href slot => $$rep{slot}, time => $$rep{date};
320     end;
321     if ($npass < $ntest or $log) {
322         start 'div', class => 'pull-right';
323         span '', class => 'toggle fa fa-caret-down', onclick => "toggle('$slotid', this)";
324         end;
325     }
326     end;
327     end 'tr';
328     print "\n";
329     if ($npass < $ntest && $ntest - $npass < 100) {
330         trowa { style => 'display: none' }, '';
331         print "\n";
332         my $report = load_report $$rep{slot}, $$rep{date};
333         my @fail = grep $$_{status} ne '0', @{$$report{recs}};
334         my $lastpass = load_lastpass $$rep{slot};
335
336         start 'tr', id => $slotid, class => 'slotfail';
337         start 'td', colspan => 8;
338         start 'table', class => 'minirep';
339         start 'thead';
340         start 'tr';
341         if ($$rep{nfail} eq 1) {
342             th "1 failed test";
343         } else {
344             th "$$rep{nfail} failed tests";
345         }
346         th 'Status', class => 'errcode';
347         end 'tr';
348         end 'thead';
349         start 'tbody';
350         for (sort { $$a{name} cmp $$b{name} } @fail) {
351             my $falert = $$rep{pdate} eq $$lastpass{$$_{name}}{date} ?
352               'warn' : '';
353             start 'tr', class => "$falert";
354             td $$_{name};
355             td $$_{status}, class => 'errcode';
356             end 'tr';
357         }
358         end 'tbody';
359         end 'table';
360         end 'td';
361         end 'tr';
362         print "\n";
363     } elsif ($log) {
364         trowa { style => 'display: none' }, '';
365         start 'tr', id => $slotid, class => 'slotfail';
366         start 'td', colspan => 8;
367         start 'pre', class => 'minilog';
368         print encode_entities($log, '<>&"');
369         end 'pre';
370         end 'td';
371         end 'tr';
372     }
373 }
374 end 'tbody';
375 end 'table';
376 end 'div';
377 footer;