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