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