view: Handle bugs without subjects gracefully.
[software/mumi.git] / mumi / web / view / html.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 (define-module (mumi web view html)
20 #:use-module (debbugs bug)
21 #:use-module (email email)
22 #:use-module (mumi config)
23 #:use-module (mumi messages)
24 #:use-module (mumi web view utils)
25 #:use-module (ice-9 match)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-19)
28 #:export (index
29 help
30 unknown
31 error-page
32 issue-page
33 list-of-matching-bugs
34 list-of-bugs
35 priority-bugs))
36
37 (define (bug-subject* bug)
38 (or (bug-subject bug) "(no subject)"))
39
40 (define (status-tag bug)
41 "Return a colored tag indicating the BUG status."
42 (let ((status (if (bug-done bug) "Done" "Open")))
43 `(span (@ (class ,(string-append "status-tag "
44 (string-downcase status))))
45 ,status)))
46
47 (define* (layout #:key
48 (head '())
49 (body '())
50 (title "Guix issue tracker")
51 (extra-headers '()))
52 `(#:sxml ((doctype "html")
53 (html
54 (head
55 (title ,title)
56 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
57 (meta (@ (http-equiv "Content-Language") (content "en")))
58 (meta (@ (name "author") (content "Ricardo Wurmus")))
59 (meta (@ (name "viewport")
60 (content "width=device-width, initial-scale=1")))
61 (link
62 (@ (rel "stylesheet")
63 (media "screen")
64 (type "text/css")
65 (href "/css/reset.css")))
66 (link
67 (@ (rel "stylesheet")
68 (media "screen")
69 (type "text/css")
70 (href "/css/bootstrap.css")))
71 ,@head
72 (link
73 (@ (rel "stylesheet")
74 (media "screen")
75 (type "text/css")
76 (href "/css/screen.css")))
77 (link
78 (@ (rel "stylesheet")
79 (media "screen")
80 (type "text/css")
81 (href "/css/code.css"))))
82 (body ,@body
83 (footer
84 (p "Copyright © 2016—2019 by the GNU Guix community."
85 (br)
86 "Now with even more " (span (@ (class "lambda")) "λ") "! ")
87 (p "This is free software. Download the "
88 (a (@ (href "https://git.elephly.net/software/mumi.git"))
89 "source code here") ".")))))
90 #:extra-headers ,extra-headers))
91
92 (define* (search-form #:key (standalone? #f))
93 `(form (@ (id "search")
94 ,(if standalone?
95 '(class "row")
96 '(class "navbar-form navbar-right"))
97 (action "/search"))
98 (div
99 (@ (class ,(if standalone?
100 "input-group input-group-lg"
101 "input-group")))
102 (input (@ (type "text")
103 (class "form-control")
104 (id "query")
105 (name "query")
106 (placeholder "input search query")))
107 (span (@ (class "input-group-btn"))
108 (button
109 (@ (type "submit")
110 (class ,(string-append (if standalone? "btn-lg " "")
111 "btn btn-primary")))
112 "Search")))))
113
114 (define* (header #:key (search-bar? #t))
115 `(nav
116 (@ (id "header") (class "navbar navbar-default"))
117 (div
118 (@ (class "container-fluid"))
119 (div
120 (@ (class "navbar-header"))
121 (div (@ (class "navbar-brand"))
122 (a (@ (href "/") (class "logo")))))
123 ,@(if search-bar?
124 `(,(search-form))
125 '()))))
126
127 (define (index)
128 (layout
129 #:extra-headers
130 '((cache-control . ((max-age . 60))))
131 #:body
132 `(,(header #:search-bar? #f)
133 (div
134 (@ (class "container"))
135 (h1 "Guix patch tracker")
136 (p (@ (class "row"))
137 "This is a web frontend to the Guix patch tracker. Send email to "
138 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
139 ,(%config 'submission-email-address))
140 " to submit your patches.")
141 ,(search-form #:standalone? #t)
142 (div
143 (@ (class "row"))
144 (div
145 (@ (class "panel panel-default"))
146 (p (@ (class "panel-body"))
147 (strong "Hint: ")
148 "Refine your search with filters like "
149 (span (@ (class "filter"))
150 "is:open")
151 ", "
152 (span (@ (class "filter"))
153 "author:me")
154 ", "
155 (span (@ (class "filter"))
156 "submitter:me")
157 ", "
158 (span (@ (class "filter"))
159 "date:yesterday..now")
160 ", "
161 (span (@ (class "filter"))
162 "date:2018-04-01..2018-04-02")
163 ", "
164 (span (@ (class "filter"))
165 "date:1m..today")
166 ", "
167 (span (@ (class "filter"))
168 "mdate:2w..12h")
169 ", and "
170 (a (@ (href "help#search"))
171 "many more!"))))
172 (h2 "Recent activity")
173 (div (@ (id "snippet-recent"))
174 (img (@ (src "/img/spin.gif"))))
175 (h2 "Priority bugs")
176 (div (@ (id "snippet-priority"))
177 (img (@ (src "/img/spin.gif"))))
178 (script
179 (@ (type "text/javascript")
180 (src "/js/mumi.js")))))))
181
182 (define (help)
183 (layout
184 #:extra-headers
185 ;; Cache for 24 hours.
186 '((cache-control . ((max-age . 86400))))
187 #:body
188 `(,(header #:search-bar? #f)
189 (div
190 (@ (class "container"))
191 (h1 "Help")
192 (a (@ (href "search")))
193 (p "You can improve the search results by making use of the
194 simple query language. Here is a list of supported query terms with
195 some examples.")
196 (table
197 (@ (class "table"))
198 (thead
199 (tr
200 (th (@ (class "col-md-3")) "Filter")
201 (th (@ (class "col-md-9")) "Description")))
202 (tbody
203 (tr
204 (td (span (@ (class "filter")) "is:open") ", "
205 (span (@ (class "filter")) "is:pending"))
206 (td "Open issues."))
207 (tr
208 (td (span (@ (class "filter")) "is:closed") ", "
209 (span (@ (class "filter")) "is:done"))
210 (td "Issues marked as done."))
211 (tr
212 (td (span (@ (class "filter")) "submitter:<who>"))
213 (td "Issues submitted by a person named " (strong "who")
214 ", e.g. "
215 (span (@ (class "filter")) "submitter:ludo")
216 " for all issues submitted by ludo. "
217 "The filter matches both the email address and the name."))
218 (tr
219 (td (span (@ (class "filter")) "author:<who>"))
220 (td "Issues where a person named " (strong "who")
221 " has commented, e.g. "
222 (span (@ (class "filter")) "author:rekado")
223 " for all messages where rekado has commented. "
224 "The filter matches both the email address and the name."))
225 (tr
226 (td (span (@ (class "filter")) "date:<start>..<end>"))
227 (td "Issues submitted within the provided range. "
228 (strong "start") " and " (strong "end") " can be one of "
229 (strong "now") ", " (strong "today") ", " (strong "yesterday")
230 ", a date in the formats "
231 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
232 ", or an amount and a unit for a point in the past, such as "
233 (strong "12d") " for 12 days ago. "
234 "Supported units are: "
235 (strong "h") " (hours), "
236 (strong "d") " (days), "
237 (strong "w") " (weeks), "
238 (strong "m") " (months), and "
239 (strong "y") " (years)."))
240 (tr
241 (td (span (@ (class "filter")) "mdate:<start>..<end>"))
242 (td "Issues with comments submitted within the provided
243 range. The supported arguments are the same as for "
244 (span (@ (class "filter")) "date:") "."))))))))
245
246 (define (unknown id)
247 (layout
248 #:body
249 `(,(header)
250 (div (@ (class "container"))
251 (h1 "Patch not found")
252 (p "There is no submission with id " (strong ,id))
253 (p (a (@ (href "/")) "Try another one?"))))))
254
255 (define (error-page message)
256 (layout
257 #:body
258 `(,(header)
259 (div (@ (class "container"))
260 (h1 "Error")
261 (p "An error occurred. Sorry about that!")
262 ,message
263 (p (a (@ (href "/")) "Try something else?"))))))
264
265 (define (issue-page bug)
266 "Render the conversation for the given BUG."
267 (define id (bug-num bug))
268 (define messages (patch-messages id))
269 (define parties (sort (filter (compose (negate bot?) extract-email)
270 (participants messages))
271 (lambda (a b)
272 (string< (extract-email a)
273 (extract-email b)))))
274 (define (show-message message-number message previous-subject)
275 `((div
276 (@ (class "row"))
277 (a (@ (id ,(number->string message-number))))
278 (div
279 (@ (class "avatar col-md-1")
280 (style ,(string-append "background-color:"
281 (avatar-color (sender-email message)
282 (map extract-email parties)))))
283 ,(string-upcase (string-take (sender-name message) 1)))
284 (div
285 (@ (class "message col-md-11"))
286 (div
287 (@ (class "panel panel-default"))
288 (div
289 (@ (class "panel-heading"))
290 (div
291 (@ (class "from"))
292 (span (@ (class "address")) ,(sender-name message))
293 " wrote on "
294 (span (@ (class "date"))
295 (a (@ (href ,(string-append "#" (number->string
296 message-number))))
297 ,(date->string (date message)))))
298 ,@(if (string-suffix? previous-subject (subject message))
299 '()
300 `((div (@ (class "subject")) ,(subject message))))
301 (div
302 (@ (class "details"))
303 (div
304 (@ (class "recipients"))
305 (label "Recipients:")
306 ,(map (lambda (address)
307 `(span (@ (class "address")) ,address))
308 (recipients message)))
309 (div
310 (@ (class "message-id"))
311 (label "Message-ID:")
312 ,(message-id message))))
313 (div
314 (@ (class "body panel-body"))
315 ,(display-message-body id message-number message)))))
316 ,@(if (closing? message id)
317 '((div
318 (@ (class "row event"))
319 (div
320 (@ (class "col-md-offset-1 col-md-11 text-center"))
321 (div (@ (class "label label-primary closed")) "Closed"))))
322 '())))
323 (layout
324 #:title (bug-subject* bug)
325 #:extra-headers
326 (cond
327 ((bug-archived bug)
328 ;; Tell browser to cache this for 12 hours.
329 '((cache-control . ((max-age . 43200)))))
330 ((bug-done bug)
331 ;; Tell browser to cache this for 1 hour.
332 '((cache-control . ((max-age . 3600)))))
333 (else '()))
334 #:body
335 `(,(header)
336 (div
337 (@ (class "container"))
338 (div
339 (@ (class "row title col-md-12"))
340 (h1 ,(bug-subject* bug))
341 (span (@ (class "details"))
342 ,(status-tag bug)
343 ,(string-append "Submitted by "
344 ;; We don't use bug-originator here
345 ;; because it includes the email address.
346 ;; We cannot use extract-name on the
347 ;; return value, because it swallows
348 ;; non-ASCII characters.
349 (sender-name (first messages))
350 ".")
351 ,@(if (bug-mergedwith bug)
352 `((ul (@ (class "merged"))
353 "Merged with: "
354 ,(map (lambda (id)
355 `(li (a (@ (href ,(string-append "/issue/" id)))
356 ,id)))
357 ;; XXX: This field can either hold a
358 ;; string of multiple ids, or a single
359 ;; number. Deal with this mess.
360 (match (bug-mergedwith bug)
361 ((? string? str)
362 (string-split str #\space))
363 ((? number? n)
364 (list (number->string n)))))))
365 '())
366 ,@(if (bug-blocks bug)
367 `((ul (@ (class "blocks"))
368 "Blocks: "
369 ,(map (lambda (id)
370 `(li (a (@ (href ,(string-append "/issue/" id)))
371 ,id)))
372 ;; XXX: This field can either hold a
373 ;; string of multiple ids, or a single
374 ;; number. Deal with this mess.
375 (match (bug-blocks bug)
376 ((? string? str)
377 (string-split str #\space))
378 ((? number? n)
379 (list (number->string n)))))))
380 '())
381 ,@(if (bug-blockedby bug)
382 `((ul (@ (class "blockedby"))
383 "Blocked by: "
384 ,(map (lambda (id)
385 `(li (a (@ (href ,(string-append "/issue/" id)))
386 ,id)))
387 ;; XXX: This field can either hold a
388 ;; string of multiple ids, or a single
389 ;; number. Deal with this mess.
390 (match (bug-blockedby bug)
391 ((? string? str)
392 (string-split str #\space))
393 ((? number? n)
394 (list (number->string n)))))))
395 '())))
396 (div
397 (@ (class "row"))
398 (div
399 (@ (class "conversation col-md-9"))
400 ,(let ((msgs (filter (lambda (msg)
401 ;; Ignore messages
402 ;; without body, and
403 ;; internal messages.
404 (and (email-body msg)
405 (not (internal-message? msg))))
406 messages)))
407 (map (lambda (message-number msg previous-subject)
408 (show-message message-number msg previous-subject))
409 (iota (length msgs))
410 msgs
411 (cons (bug-subject* bug)
412 (map subject msgs))))
413 (div
414 (@ (class "row comment-box"))
415 (a (@ (id "comment")))
416 (div
417 (@ (class "avatar col-md-1")
418 (style "background-color:#bc80bd")) "?")
419 (div
420 (@ (class "message col-md-11"))
421 (div
422 (@ (class "panel panel-default"))
423 (div
424 (@ (class "panel-heading"))
425 (div (@ (class "from"))
426 (span (@ (class "address")) "Your comment")))
427 (div
428 (@ (class "body panel-body"))
429 (p "Comments via the web interface are not currently
430 supported. To comment on this conversation "
431 (a (@ (href ,(string-append "mailto:"
432 (number->string id) "@" (%config 'debbugs-domain)
433 "?subject=" (bug-subject* bug))))
434 ,(string-append "send email to "
435 (number->string id) "@" (%config 'debbugs-domain)))))))))
436
437 (div
438 (@ (class "info col-md-3"))
439 (div
440 (@ (class "stat"))
441 ,@(let ((num (length parties)))
442 `((label ,(if (= num 1)
443 "One participant"
444 (string-append (number->string num)
445 " participants")))
446 (ul ,(map (lambda (name)
447 `(li (span (@ (class "name")))
448 ,name))
449 (map extract-name parties))))))
450 (div
451 (@ (class "stat"))
452 (label "Owner")
453 ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
454 (div
455 (@ (class "stat"))
456 (label "Severity")
457 ,(bug-severity bug))
458 (div
459 (@ (class "stat"))
460 (label "Status")
461 ,(status-tag bug))))))))
462
463 (define (list-of-bugs bugs)
464 "Return a table of BUGS."
465 (if (null? bugs)
466 `(p "Nothing to see here. "
467 (a (@ (href "/"))
468 "Look for something else?"))
469 `(table (@ (class "table-condensed"))
470 (thead
471 (tr (th "ID")
472 (th "Subject")
473 (th "Date submitted")
474 (th "Status")))
475 (tbody
476 ,@(map (lambda (bug)
477 (let ((id (number->string (bug-num bug))))
478 `(tr (@ (class ,(bug-severity bug)))
479 (td ,(or id "-"))
480 (td ,(if id
481 `(a (@ (href ,(string-append "/issue/" id)))
482 ,(bug-subject* bug))
483 (bug-subject* bug)))
484 (td ,(date->string (bug-date bug)))
485 (td ,(status-tag bug)))))
486 bugs)))))
487
488 (define (priority-bugs)
489 (list #:sxml
490 (list-of-bugs
491 (sort
492 (append
493 (bugs-by-severity "serious" "open")
494 (bugs-by-severity "important" "open"))
495 (lambda (a b) (< (bug-num a) (bug-num b)))))))
496
497 (define (list-of-matching-bugs query bugs)
498 (layout
499 #:body
500 `(,(header)
501 (div (@ (class "container"))
502 ,@(if (null? bugs)
503 `((h1 "No issues found")
504 (p "We could not find any issues matching your query "
505 (code ,query) ". "
506 (a (@ (href "/"))
507 "Try searching for something else?")))
508 `((h1 "Submissions matching " (code ,query))
509 ,(list-of-bugs bugs)))))))