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