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