view/html: Mention alternative way of commenting.
[software/mumi.git] / mumi / web / view / html.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 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 (mumi web util)
26 #:use-module (ice-9 match)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-19)
29 #:export (index
30 help
31 unknown
32 error-page
33 issue-page
34 list-of-matching-bugs
35 list-of-recent-issues))
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 `((doctype "html")
52 (html (@ (lang "en"))
53 (head
54 (title ,title)
55 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
56 (meta (@ (name "author") (content "Ricardo Wurmus")))
57 (meta (@ (name "viewport")
58 (content "width=device-width, initial-scale=1")))
59 (link
60 (@ (rel "stylesheet")
61 (media "screen")
62 (type "text/css")
63 (href "/css/reset.css")))
64 (link
65 (@ (rel "stylesheet")
66 (media "screen")
67 (type "text/css")
68 (href "/css/bootstrap.css")))
69 ,@head
70 (link
71 (@ (rel "stylesheet")
72 (media "screen")
73 (type "text/css")
74 (href "/css/screen.css?202005070001"))))
75 (body ,@body
76 (footer (@ (class "text-center"))
77 (p "Copyright © 2016—2020 by the GNU Guix community."
78 (br)
79 "Now with even more " (span (@ (class "lambda")) "λ") "! ")
80 (p "This is free software. Download the "
81 (a (@ (href "https://git.elephly.net/software/mumi.git"))
82 "source code here") "."))
83 (script
84 (@ (src "/js/sort-table.js")))))))
85
86 (define* (search-form #:key (standalone? #f) (text ""))
87 `(form (@ (id "search")
88 ,(if standalone?
89 '(class "")
90 '(class "form-inline"))
91 (action "/search"))
92 (div
93 (@ (class ,(if standalone?
94 "input-group input-group-lg"
95 "input-group")))
96 (input (@ (type "text")
97 (class "form-control")
98 (id "query")
99 (name "query")
100 (value ,text)
101 (placeholder "Input your search query...")))
102 (span (@ (class "input-group-append"))
103 (button
104 (@ (type "submit")
105 (class ,(string-append (if standalone? "btn-lg " "")
106 "btn btn-primary")))
107 ;; This SVG is part of Bootstrap and is available
108 ;; under the Expat license.
109 (svg
110 (@ (class "bi bi-search")
111 (width "1em")
112 (height "1em")
113 (viewBox "0 0 16 16")
114 (fill "currentColor")
115 (xmlns "http://www.w3.org/2000/svg"))
116 (title "Search")
117 (path (@ (fill-rule "evenodd")
118 (d "M10.442 10.442a1 1 0 011.415 0l3.85 3.85a1 1 0 01-1.414 1.415l-3.85-3.85a1 1 0 010-1.415z")
119 (clip-rule "evenodd")) "")
120 (path (@ (fill-rule "evenodd")
121 (d "M6.5 12a5.5 5.5 0 100-11 5.5 5.5 0 000 11zM13 6.5a6.5 6.5 0 11-13 0 6.5 6.5 0 0113 0z")
122 (clip-rule "evenodd")) ""))))
123 (div
124 (@ (id "search-hints"))
125 (p "You can improve the search results by making use of the
126 simple query language. Here is a list of supported query terms:")
127 (table
128 (@ (class "table table-sm table-borderless"))
129 (tbody
130 ,@(map (match-lambda
131 ((term description)
132 `(tr (td (span (@ (class "filter")) ,term))
133 (td ,description))))
134 '(("is:open" "open issues")
135 ("is:done" "closed issues")
136 ("submitter:<who>" "search issue submitter")
137 ("author:<who>" "search by message author")
138 ("date:yesterday..now" "search by issue date")
139 ("mdate:3m..2d" "search by message date")))))))))
140
141 (define* (search-widget #:key (text ""))
142 `(div
143 (@ (class "card mb-3"))
144 (div (@ (class "card-body bg-light"))
145 ,(search-form #:standalone? #t #:text text)
146 (details
147 (summary (strong "Hint"))
148 (p
149 "Refine your search with filters like "
150 (span (@ (class "filter"))
151 "is:open")
152 ", "
153 (span (@ (class "filter"))
154 "author:me")
155 ", "
156 (span (@ (class "filter"))
157 "submitter:me")
158 ", "
159 (span (@ (class "filter"))
160 "date:2d..now")
161 ", "
162 (span (@ (class "filter"))
163 "date:2018-04-01..2018-04-02")
164 ", "
165 (span (@ (class "filter"))
166 "date:1m..today")
167 ", and "
168 (a (@ (href "help#search"))
169 "many more!"))))))
170
171 (define* (header #:key (search-bar? #t) title)
172 `(nav
173 (@ (class "sticky-top navbar navbar-expand navbar-light bg-light"))
174 (a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
175 (img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
176 ,@(if title
177 `((span (@ (class "navbar-text")) ,title))
178 '())
179 ,@(if search-bar?
180 `(,(search-form))
181 '())))
182
183 (define (index)
184 (layout
185 #:body
186 `(,(header #:search-bar? #f)
187 (main
188 (@ (class "container"))
189 (h1 "Guix issue tracker")
190 (p (@ (class "lead"))
191 "This is a web frontend to the Guix patch and bug trackers. Send email to "
192 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
193 ,(%config 'submission-email-address))
194 " to submit a patch, or email "
195 (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
196 ,(%config 'submission-bug-email-address))
197 " to submit a bug report.")
198 ,(search-widget)
199
200 (div (@ (class "mt-4 h4")) "Recent activity "
201 (small (a (@ (href "recent")) "(More)")))
202 (table
203 (@ (class "table table-borderless table-hover js-sort-table"))
204 (thead
205 (tr (@ (class "heading"))
206 (th (@ (class "js-sort-number")) "ID")
207 (th "Subject")
208 (th "Date submitted")
209 (th "Status")))
210 (tbody
211 ,@(list-of-bugs (recent-bugs 10))))
212
213 (div (@ (class "mt-4 h4")) "Priority bugs")
214 (table
215 (@ (class "table table-borderless table-hover js-sort-table"))
216 (thead
217 (tr (@ (class "heading"))
218 (th (@ (class "js-sort-number")) "ID")
219 (th "Subject")
220 (th "Date submitted")
221 (th "Status")))
222 (tbody
223 ,@(priority-bugs)))))))
224
225 (define (help)
226 (layout
227 #:body
228 `(,(header #:search-bar? #f)
229 (div
230 (@ (class "container"))
231 (h1 "Help")
232 (a (@ (href "search")))
233 (p "You can improve the search results by making use of the
234 simple query language. Here is a list of supported query terms with
235 some examples.")
236 (table
237 (@ (class "table"))
238 (thead
239 (tr
240 (th (@ (class "col-md-3")) "Filter")
241 (th (@ (class "col-md-9")) "Description")))
242 (tbody
243 (tr
244 (td (span (@ (class "filter")) "is:open") ", "
245 (span (@ (class "filter")) "is:pending"))
246 (td "Open issues."))
247 (tr
248 (td (span (@ (class "filter")) "is:closed") ", "
249 (span (@ (class "filter")) "is:done"))
250 (td "Issues marked as done."))
251 (tr
252 (td (span (@ (class "filter")) "submitter:<who>"))
253 (td "Issues submitted by a person named " (strong "who")
254 ", e.g. "
255 (span (@ (class "filter")) "submitter:ludo")
256 " for all issues submitted by ludo. "
257 "The filter matches both the email address and the name."))
258 (tr
259 (td (span (@ (class "filter")) "author:<who>"))
260 (td "Issues where a person named " (strong "who")
261 " has commented, e.g. "
262 (span (@ (class "filter")) "author:rekado")
263 " for all messages where rekado has commented. "
264 "The filter matches both the email address and the name."))
265 (tr
266 (td (span (@ (class "filter")) "date:<start>..<end>"))
267 (td "Issues submitted within the provided range. "
268 (strong "start") " and " (strong "end") " can be one of "
269 (strong "now") ", " (strong "today")
270 ", a date in the formats "
271 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
272 ", or an amount and a unit for a point in the past, such as "
273 (strong "12d..") " for 12 days ago. "
274 "Supported units are: "
275 (strong "h") " (hours), "
276 (strong "d") " (days), "
277 (strong "w") " (weeks), "
278 (strong "m") " (months), and "
279 (strong "y") " (years)."))
280 (tr
281 (td (span (@ (class "filter")) "mdate:<start>..<end>"))
282 (td "This is just like " (span (@ (class "filter")) "date")
283 " except that it also includes comments."))))))))
284
285 (define (unknown id)
286 (layout
287 #:body
288 `(,(header)
289 (div (@ (class "container"))
290 (h1 "Issue not found")
291 (p "There is no submission with id " (strong ,id) ", or we
292 failed to process associated messages.")
293 (p (a (@ (href "/")) "Try another one?"))))))
294
295 (define (error-page message)
296 (layout
297 #:body
298 `(,(header)
299 (div (@ (class "container"))
300 (h1 "Error")
301 (p "An error occurred. Sorry about that!")
302 ,message
303 (p (a (@ (href "/")) "Try something else?"))))))
304
305 (define* (issue-page bug #:optional flash-message)
306 "Render the conversation for the given BUG."
307 (define id (bug-num bug))
308 (define messages (issue-messages id))
309 (define parties (sort (filter (compose (negate bot?) extract-email)
310 (participants (filter identity messages)))
311 (lambda (a b)
312 (string< (extract-email a)
313 (extract-email b)))))
314 (define sidebar
315 `(ul (@ (id "sidebar")
316 (class "sticky-top flex-column"))
317 ,(map (lambda (message message-number)
318 `(li
319 (div
320 (@ (class "avatar")
321 (style ,(string-append "background-color:"
322 (avatar-color (sender-email message)
323 (map extract-email parties)))))
324 ,(string-upcase (string-take (sender-name message) 1)))
325 (span (@ (class "date"))
326 (a (@ (href ,(string-append "#" (number->string
327 message-number))))
328 ,(date->string (date message))))))
329 messages
330 (iota (length messages)))))
331 (define issue-details
332 `(span (@ (class "details"))
333 ,(status-tag bug)
334 ,(string-append "Submitted by "
335 ;; We don't use bug-originator here
336 ;; because it includes the email address.
337 ;; We cannot use extract-name on the
338 ;; return value, because it swallows
339 ;; non-ASCII characters.
340 (sender-name (first messages))
341 ".")
342 (details
343 (@ (class "info"))
344 (summary "Details")
345 (dl
346 (@ (class "stat"))
347 ,@(let ((num (length parties)))
348 `((dt ,(if (= num 1)
349 "One participant"
350 (string-append (number->string num)
351 " participants")))
352 (dd
353 (ul ,(map (lambda (name)
354 `(li (span (@ (class "name")))
355 ,name))
356 (map extract-name parties)))))))
357 (dl
358 (@ (class "stat"))
359 (dt "Owner")
360 (dd
361 ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
362 (dl
363 (@ (class "stat"))
364 (dt "Severity")
365 (dd ,(bug-severity bug)))
366 ,@(if (bug-mergedwith bug)
367 `((dl
368 (@ (class "stat"))
369 (dt "Merged with")
370 (dd (ul ,(map (lambda (id)
371 `(li (a (@ (href ,(string-append "/" id)))
372 ,id)))
373 ;; XXX: This field can either hold a
374 ;; string of multiple ids, or a single
375 ;; number. Deal with this mess.
376 (match (bug-mergedwith bug)
377 ((? string? str)
378 (string-split str #\space))
379 ((? number? n)
380 (list (number->string n)))))))))
381 '())
382 ,@(if (bug-blocks bug)
383 `((dl
384 (@ (class "stat"))
385 (dt "Blocks")
386 (dd (ul ,(map (lambda (id)
387 `(li (a (@ (href ,(string-append "/" id)))
388 ,id)))
389 ;; XXX: This field can either hold a
390 ;; string of multiple ids, or a single
391 ;; number. Deal with this mess.
392 (match (bug-blocks bug)
393 ((? string? str)
394 (string-split str #\space))
395 ((? number? n)
396 (list (number->string n)))))))))
397 '())
398 ,@(if (bug-blockedby bug)
399 `((dl
400 (@ (class "stat"))
401 (dt "Blocked by")
402 (dd (ul ,(map (lambda (id)
403 `(li (a (@ (href ,(string-append "/" id)))
404 ,id)))
405 ;; XXX: This field can either hold a
406 ;; string of multiple ids, or a single
407 ;; number. Deal with this mess.
408 (match (bug-blockedby bug)
409 ((? string? str)
410 (string-split str #\space))
411 ((? number? n)
412 (list (number->string n)))))))))
413 '()))))
414 (define comment-box
415 `(div
416 (@ (class "comment-box"))
417 (a (@ (id "comment")))
418 (div
419 (@ (class "avatar")
420 (style "background-color:#bc80bd")) "?")
421 (div
422 (@ (class "message"))
423 (div
424 (@ (class "card"))
425 ,@(if (and (mailer-enabled?)
426 (not (bug-archived bug)))
427 `((form
428 (@ (action ,(format #f "/issue/~a/comment"
429 (number->string id)))
430 (enctype "multipart/form-data")
431 (method "POST"))
432 (input (@ (style "display:none")
433 (name "validation")
434 (placeholder "Please leave this empty.")) "")
435 (input (@ (type "hidden")
436 (name "timestamp")
437 (value ,(timestamp!))) "")
438 (div
439 (@ (class "card-header"))
440 (div (@ (class "from"))
441 (input (@ (class "address form-control")
442 (name "from")
443 (required "required")
444 (placeholder "Your name")) "")))
445 (div
446 (@ (class "body card-body"))
447 (textarea (@ (name "text")
448 (required "required")
449 (class "form-control")
450 (placeholder "Please input your comment..."))
451 ""))
452 (div
453 (@ (class "card-footer"))
454 (button (@ (class "btn btn-primary")
455 (type "submit"))
456 "Send")
457 (span (@ (class "ml-3"))
458 "Your may also "
459 (a (@ (href ,(string-append "mailto:"
460 (number->string id) "@" (%config 'debbugs-domain)
461 "?subject=" (bug-subject* bug))))
462 ,(string-append "send email to "
463 (number->string id) "@" (%config 'debbugs-domain)))
464 " to comment."))))
465 `((div
466 (@ (class "card-header"))
467 (div (@ (class "from"))
468 (span (@ (class "address")) "Your comment")))
469 (div
470 (@ (class "body card-body"))
471 ,(if (bug-archived bug)
472 '(p "This issue is archived.")
473 '(p "Commenting via the web interface is
474 currently disabled."))
475 (p "To comment on this conversation "
476 (a (@ (href ,(string-append "mailto:"
477 (number->string id) "@" (%config 'debbugs-domain)
478 "?subject=" (bug-subject* bug))))
479 ,(string-append "send email to "
480 (number->string id) "@" (%config 'debbugs-domain)))))))))))
481 (define (show-message message-number message previous-subject)
482 `((div (@ (class "mb-5"))
483 (a (@ (class "message-anchor")
484 (id ,(number->string message-number))))
485 (div
486 (@ (class "avatar")
487 (style ,(string-append "background-color:"
488 (avatar-color (sender-email message)
489 (map extract-email parties)))))
490 ,(string-upcase (string-take (sender-name message) 1)))
491 (div
492 (@ (class "message"))
493 (div
494 (@ (class "card"))
495 (div
496 (@ (class "card-header"))
497 (div
498 (@ (class "from"))
499 (div
500 (@ (class "avatar")
501 (style ,(string-append "background-color:"
502 (avatar-color (sender-email message)
503 (map extract-email parties)))))
504 ,(string-upcase (string-take (sender-name message) 1)))
505 (span (@ (class "address")) ,(sender-name message))
506 " wrote on "
507 (span (@ (class "date"))
508 (a (@ (href ,(string-append "#" (number->string
509 message-number))))
510 ,(date->string (date message)))))
511 ,@(if (string-suffix? previous-subject (subject message))
512 '()
513 `((div (@ (class "subject")) ,(subject message))))
514 (div
515 (@ (class "details"))
516 (div
517 (@ (class "recipients"))
518 (label "Recipients:")
519 ,(map (lambda (address)
520 `(span (@ (class "address")) ,address))
521 (recipients message)))
522 (div
523 (@ (class "message-id"))
524 (label "Message-ID:")
525 ,(message-id message))))
526 (div
527 (@ (class "body card-body"))
528 ,(display-message-body id message-number message)))))
529 ,@(if (closing? message id)
530 '((div
531 (@ (class "row event"))
532 (div
533 (@ (class "col-11 offset-1 text-center"))
534 (div (@ (class "badge badge-primary closed")) "Closed"))))
535 '())))
536
537 (if (null? messages) #f
538 (layout
539 #:title (bug-subject* bug)
540 #:body
541 `(,(header #:title (bug-subject* bug))
542 (div
543 (@ (class "container"))
544 ,@(match flash-message
545 (('error . text)
546 `((div (@ (class "alert alert-danger")
547 (role "alert"))
548 ,text)))
549 (('info . text)
550 `((div (@ (class "alert alert-info")
551 (role "alert"))
552 ,text)))
553 (_ '()))
554 ,sidebar
555 (div
556 (@ (class "title col-12"))
557 (h1 (@ (class "h3")) ,(bug-subject* bug))
558 ,issue-details)
559 (div (@ (class "row"))
560 (div
561 (@ (class "conversation col-12"))
562 ,(let ((msgs (filter (lambda (msg)
563 ;; Ignore messages
564 ;; without body, and
565 ;; internal messages.
566 (and msg
567 (email-body msg)
568 (not (internal-message? msg))))
569 messages)))
570 (map (lambda (message-number msg previous-subject)
571 (show-message message-number msg previous-subject))
572 (iota (length msgs))
573 msgs
574 (cons (bug-subject* bug)
575 (map subject msgs))))
576 ,comment-box)))))))
577
578 (define (list-of-bugs bugs)
579 "Return table rows for all BUGS."
580 (map (lambda (bug)
581 (let ((id (number->string (bug-num bug))))
582 `(tr (@ (class ,(bug-severity bug)))
583 (td ,(or id "-"))
584 (td
585 ,@(if (member (bug-severity bug) '("serious" "important"))
586 `((svg (@ (xmlns"http://www.w3.org/2000/svg")
587 (xmlns:xlink "http://www.w3.org/1999/xlink")
588 (viewBox "0 0 14 16")
589 (version "1.1")
590 (height "1rem")
591 (width "1rem")
592 (aria-hidden "true"))
593 (title ,(bug-severity bug))
594 (path (@ (fill-rule "evenodd")
595 (d "\
596 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
597 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
598 c0-3.14 2.56-5.7 5.7-5.7z\
599 M7 1C3.14 1 0 4.14 0 8\
600 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
601 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
602 '())
603 ,(if id
604 `(a (@ (href ,(string-append "/" id)))
605 ,(bug-subject* bug))
606 (bug-subject* bug)))
607 (td ,(date->string (bug-date bug)))
608 (td ,(status-tag bug)))))
609 bugs))
610
611 (define (priority-bugs)
612 (list-of-bugs (sort
613 (append
614 (bugs-by-severity "serious" "open")
615 (bugs-by-severity "important" "open"))
616 (lambda (a b) (< (bug-num a) (bug-num b))))))
617
618 (define* (list-of-recent-issues #:optional (max 100))
619 (layout
620 #:body
621 `(,(header #:search-bar? #f)
622 (div
623 (@ (class "container"))
624 (h1 "Recent issues")
625 (table
626 (@ (class "table table-borderless table-hover js-sort-table"))
627 (thead
628 (tr (@ (class "heading"))
629 (th (@ (class "js-sort-number")) "ID")
630 (th "Subject")
631 (th "Date submitted")
632 (th "Status")))
633 (tbody
634 ,@(list-of-bugs (recent-bugs max))))))))
635
636 (define (list-of-matching-bugs query bugs)
637 (layout
638 #:body
639 `(,(header #:search-bar? #f)
640 (div
641 (@ (class "container"))
642 (h1 "Your search for " (code ,query))
643 ,(search-widget #:text query)
644 ,(if (null? bugs)
645 `(div
646 (@ (class "alert alert-warning")
647 (role "alert"))
648 (h4
649 (@ (class "alert-heading"))
650 "Nothing found!")
651 (p "We could not find any issues matching your query "
652 (code ,query) ". "
653 (a (@ (href "/"))
654 "Try searching for something else?")))
655 `(table
656 (@ (class "table table-borderless table-hover js-sort-table"))
657 (thead
658 (tr (@ (class "heading"))
659 (th (@ (class "js-sort-number")) "ID")
660 (th "Subject")
661 (th "Date submitted")
662 (th "Status")))
663 (tbody
664 ,@(list-of-bugs bugs))))))))