index: allow multiple sorting criteria
[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     if ($sort eq $key) {                           # $sort = $key
115         if ($key =~ /^desc/) {                     # $sort = desc*
116             $key =~ s/^desc//;
117         } else {                                   # $sort = *
118             $key = "desc$key";
119         }
120     }
121
122     anchor $text, href => "$uri?${params}sort=$key";
123 }
124
125 sub category {
126     my ($category, $rep) = @_;
127     my $head_printed = 0;
128
129     # $params will contain parameters else than query, if any, in HTTP format.
130     my $params = '';
131     for my $thisparam (param) {
132         next if $thisparam eq 'query';
133         $params .= '&' if $params ne '';
134         $params .= "$thisparam=" . param($thisparam);
135     }
136     my $head = ($params ? '&' : '') . 'query=';
137
138     if (@queries) {
139         for my $this_query (@queries) {
140             my ($type, $text) = split(/:/, $this_query, 2);
141             if ($type ne $category) {
142                 $params .= $head if (!$head_printed);
143                 $params .= $this_query . '//';
144                 $head_printed = 1;
145             }
146         }
147     }
148     $params .= $head if (!$head_printed);
149     $params .= "$category:" . uri_escape_utf8 "$$rep{$category}" . '//';
150     $head_printed = 1;                 # for the sake of completeness
151
152     start 'td';
153     anchor $$rep{$category}, href => "$uri?$params";
154     end 'td';
155 }
156
157 print "Content-type: text/html\r\n";
158
159 if ($ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/) {
160     print "Content-Encoding: gzip\r\n\r\n";
161     open STDOUT, '|-', 'gzip';
162 } else {
163     print "\r\n";
164 }
165
166 doctype;
167 start 'html', xmlns => "http://www.w3.org/1999/xhtml";
168 start 'head';
169 tag 'meta', 'http-equiv' => "Content-Type",
170             'content'    => "text/html; charset=utf-8";
171 tag 'link', rel  => 'stylesheet',
172             type => 'text/css',
173             href => '//ffmpeg.org/default.css';
174 tag 'link', rel  => 'stylesheet',
175             type => 'text/css',
176             href => '/fate.css';
177 print "<title>FATE</title>\n";
178 print <<EOF;
179 <script type="text/javascript">
180   function toggle(id, arr) {
181       var e = document.getElementById(id);
182       if (e.style.display == 'table-row') {
183           e.style.display = 'none';
184           arr.textContent = '\\u25b6'
185       } else {
186           e.style.display = 'table-row';
187           arr.textContent = '\\u25bc'
188       }
189   }
190 </script>
191 EOF
192 end 'head';
193
194 start 'body';
195 start 'div', id => 'container';
196
197 navbar;
198
199 start 'div', id => 'body';
200
201 h1 'FATE';
202
203 if (@queries) {
204     start 'p';
205     print 'Search patterns: ';
206     for my $this_query (@queries) {
207         my ($type, $text) = split(/:/, $this_query, 2);
208         print "$type: $text; ";
209     }
210     anchor 'clear all.', href => "$uri";
211     end 'p';
212 }
213
214 start 'table', id => 'index', class => 'replist';
215 start 'thead';
216 start 'tr';
217 start 'td', colspan => 10, id => 'failometer';
218 span '&nbsp;', class => 'pass', style => "width: ${allpass}%" if $allpass;
219 span '&nbsp;', class => 'warn', style => "width: ${warn}%"    if $warn;
220 span '&nbsp;', class => 'fail', style => "width: ${allfail}%" if $allfail;
221 end 'td';
222 end 'tr';
223 start 'tr';
224 start 'th'; lsort 'Time',     'descdate';      end 'th';
225 start 'th'; lsort 'Rev',      'rev';           end 'th';
226 start 'th'; lsort 'Arch',     'arch';          end 'th';
227 start 'th'; lsort 'OS',       'os';            end 'th';
228 start 'th'; lsort 'Compiler', 'cc';            end 'th';
229 start 'th'; lsort 'Comment',  'comment';       end 'th';
230 start 'th', colspan => 2; lsort 'Warnings', 'nwarn'; end 'th';
231 start 'th', colspan => 2; lsort 'Tests', 'npass'; end 'th';
232 end 'tr';
233 end 'thead';
234 start 'tbody';
235 for my $rep (sort repcmp @reps) {
236     my $ntest = $$rep{ntests};
237     my $npass = $$rep{npass};
238     my $time = parse_date $$rep{date};
239     my $age  = time - tz_local_offset() - $time;
240     my $agestr = agestr $age, $time;
241     my $ageclass = '';
242     my $rtext;
243     my $rclass;
244     my $log;
245     my $alert = ('rejoice', '', 'alert')[$$rep{alert} + 1];
246     my $walert = ('rejoice', '', 'alert')[$$rep{dwarn} + 1];
247     (my $slotid = $$rep{slot}) =~ s/[^a-z0-9_-]/_/ig;
248
249     if ($age < $recent_age) {
250         $ageclass = 'recent';
251     } elsif ($age > $ancient_age) {
252         $ageclass = 'ancient';
253         $alert = '';
254     }
255
256     start 'tr', class => "$ageclass $alert alt hilight";
257     start 'td';
258     anchor $agestr, href => href slot => $$rep{slot};
259     end 'td';
260     if ($gitweb and $$rep{rev} =~ /(N-)?(.*)/) {
261         start 'td';
262         anchor $$rep{rev}, href => "$gitweb;a=commit;h=$2";
263         end 'td';
264     } else {
265         td $$rep{rev};
266     }
267
268     category 'subarch', $rep;
269     category 'os', $rep;
270     category 'cc', $rep;
271     td $$rep{comment}, class => 'comment';
272     if ($npass) {
273         $rtext  = "$npass / $ntest";
274         $rclass = $npass==$ntest? 'pass' : $npass? 'warn' : 'fail';
275     } elsif (!$ntest and !$$rep{status}) {
276         $rtext  = "build only";
277         $rclass = $$rep{status}? 'fail' : 'pass';
278     } else {
279         $rtext  = $$rep{errstr};
280         $rclass = 'fail';
281         for my $base ('test', 'compile', 'configure') {
282             my $file = "$fatedir/$$rep{slot}/$$rep{date}/$base.log.gz";
283             if (-r $file) {
284                 $log = qx{zcat $file | tail -n20};
285                 last;
286             }
287         }
288     }
289     start 'td', class => 'warnleft';
290     anchor $$rep{nwarn}, class => $walert,
291       href => href slot => $$rep{slot}, time => $$rep{date}, log => 'compile';
292     end;
293     start 'td', class => 'warnright';
294     anchor '±', class => $walert,
295       href => href slot => $$rep{slot}, time => $$rep{date},
296         log => "compile/$$rep{pdate}";
297     end;
298     start 'td', class => "$rclass resleft";
299     anchor $rtext, href => href slot => $$rep{slot}, time => $$rep{date};
300     end 'td';
301     start 'td', class => "$rclass resright";
302     if ($npass < $ntest or $log) {
303         span '&#9654;', class => 'toggle', onclick => "toggle('$slotid', this)";
304     }
305     end 'td';
306     end 'tr';
307     print "\n";
308     if ($npass < $ntest && $ntest - $npass < 100) {
309         my $report = load_report $$rep{slot}, $$rep{date};
310         my @fail = grep $$_{status} ne '0', @{$$report{recs}};
311         my $lastpass = load_lastpass $$rep{slot};
312
313         start 'tr', id => $slotid, class => 'slotfail';
314         start 'td', colspan => 10;
315         start 'table', class => 'minirep';
316         start 'thead';
317         start 'tr';
318         if ($$rep{nfail} eq 1) {
319             th "1 failed test";
320         } else {
321             th "$$rep{nfail} failed tests";
322         }
323         th 'Status', class => 'errcode';
324         end 'tr';
325         end 'thead';
326         start 'tbody';
327         for (sort { $$a{name} cmp $$b{name} } @fail) {
328             my $falert = $$rep{pdate} eq $$lastpass{$$_{name}}{date} ?
329               'alert' : '';
330             start 'tr', class => "alt hilight $falert";
331             td $$_{name};
332             td $$_{status}, class => 'errcode';
333             end 'tr';
334         }
335         end 'tbody';
336         end 'table';
337         end 'td';
338         end 'tr';
339         print "\n";
340         trowa { style => 'display: none' }, '';
341     } elsif ($log) {
342         start 'tr', id => $slotid, class => 'slotfail';
343         start 'td', colspan => 10;
344         start 'pre', class => 'minilog';
345         print encode_entities($log, '<>&"');
346         end 'pre';
347         end 'td';
348         end 'tr';
349         trowa { style => 'display: none' }, '';
350     }
351 }
352 end 'tbody';
353 end 'table';
354 end 'div';
355 end 'div';
356 end 'body';
357 end 'html';