html: Add a sidebar to quickly jump to messages.
[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 (mailer-enabled?)
426 `((form
427 (@ (action ,(format #f "/issue/~a/comment"
428 (number->string id)))
429 (enctype "multipart/form-data")
430 (method "POST"))
431 (input (@ (style "display:none")
432 (name "validation")
433 (placeholder "Please leave this empty.")) "")
434 (input (@ (type "hidden")
435 (name "timestamp")
436 (value ,(timestamp!))) "")
437 (div
438 (@ (class "card-header"))
439 (div (@ (class "from"))
440 (input (@ (class "address form-control")
441 (name "from")
442 (required "required")
443 (placeholder "Your name")) "")))
444 (div
445 (@ (class "body card-body"))
446 (textarea (@ (name "text")
447 (required "required")
448 (class "form-control")
449 (placeholder "Please input your comment..."))
450 ""))
451 (div
452 (@ (class "card-footer"))
453 (button (@ (class "btn btn-primary")
454 (type "submit"))
455 "Send"))))
456 `((div
457 (@ (class "card-header"))
458 (div (@ (class "from"))
459 (span (@ (class "address")) "Your comment")))
460 (div
461 (@ (class "body card-body"))
462 (p "Comments via the web interface are not currently
463 supported. To comment on this conversation "
464 (a (@ (href ,(string-append "mailto:"
465 (number->string id) "@" (%config 'debbugs-domain)
466 "?subject=" (bug-subject* bug))))
467 ,(string-append "send email to "
468 (number->string id) "@" (%config 'debbugs-domain)))))))))))
469 (define (show-message message-number message previous-subject)
470 `((div (@ (class "mb-5"))
471 (a (@ (class "message-anchor")
472 (id ,(number->string message-number))))
473 (div
474 (@ (class "avatar")
475 (style ,(string-append "background-color:"
476 (avatar-color (sender-email message)
477 (map extract-email parties)))))
478 ,(string-upcase (string-take (sender-name message) 1)))
479 (div
480 (@ (class "message"))
481 (div
482 (@ (class "card"))
483 (div
484 (@ (class "card-header"))
485 (div
486 (@ (class "from"))
487 (div
488 (@ (class "avatar")
489 (style ,(string-append "background-color:"
490 (avatar-color (sender-email message)
491 (map extract-email parties)))))
492 ,(string-upcase (string-take (sender-name message) 1)))
493 (span (@ (class "address")) ,(sender-name message))
494 " wrote on "
495 (span (@ (class "date"))
496 (a (@ (href ,(string-append "#" (number->string
497 message-number))))
498 ,(date->string (date message)))))
499 ,@(if (string-suffix? previous-subject (subject message))
500 '()
501 `((div (@ (class "subject")) ,(subject message))))
502 (div
503 (@ (class "details"))
504 (div
505 (@ (class "recipients"))
506 (label "Recipients:")
507 ,(map (lambda (address)
508 `(span (@ (class "address")) ,address))
509 (recipients message)))
510 (div
511 (@ (class "message-id"))
512 (label "Message-ID:")
513 ,(message-id message))))
514 (div
515 (@ (class "body card-body"))
516 ,(display-message-body id message-number message)))))
517 ,@(if (closing? message id)
518 '((div
519 (@ (class "row event"))
520 (div
521 (@ (class "col-11 offset-1 text-center"))
522 (div (@ (class "badge badge-primary closed")) "Closed"))))
523 '())))
524
525 (if (null? messages) #f
526 (layout
527 #:title (bug-subject* bug)
528 #:body
529 `(,(header #:title (bug-subject* bug))
530 (div
531 (@ (class "container"))
532 ,@(match flash-message
533 (('error . text)
534 `((div (@ (class "alert alert-danger")
535 (role "alert"))
536 ,text)))
537 (('info . text)
538 `((div (@ (class "alert alert-info")
539 (role "alert"))
540 ,text)))
541 (_ '()))
542 ,sidebar
543 (div
544 (@ (class "title col-12"))
545 (h1 (@ (class "h3")) ,(bug-subject* bug))
546 ,issue-details)
547 (div (@ (class "row"))
548 (div
549 (@ (class "conversation col-12"))
550 ,(let ((msgs (filter (lambda (msg)
551 ;; Ignore messages
552 ;; without body, and
553 ;; internal messages.
554 (and msg
555 (email-body msg)
556 (not (internal-message? msg))))
557 messages)))
558 (map (lambda (message-number msg previous-subject)
559 (show-message message-number msg previous-subject))
560 (iota (length msgs))
561 msgs
562 (cons (bug-subject* bug)
563 (map subject msgs))))
564 ,comment-box)))))))
565
566 (define (list-of-bugs bugs)
567 "Return table rows for all BUGS."
568 (map (lambda (bug)
569 (let ((id (number->string (bug-num bug))))
570 `(tr (@ (class ,(bug-severity bug)))
571 (td ,(or id "-"))
572 (td
573 ,@(if (member (bug-severity bug) '("serious" "important"))
574 `((svg (@ (xmlns"http://www.w3.org/2000/svg")
575 (xmlns:xlink "http://www.w3.org/1999/xlink")
576 (viewBox "0 0 14 16")
577 (version "1.1")
578 (height "1rem")
579 (width "1rem")
580 (aria-hidden "true"))
581 (title ,(bug-severity bug))
582 (path (@ (fill-rule "evenodd")
583 (d "\
584 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
585 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
586 c0-3.14 2.56-5.7 5.7-5.7z\
587 M7 1C3.14 1 0 4.14 0 8\
588 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
589 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
590 '())
591 ,(if id
592 `(a (@ (href ,(string-append "/" id)))
593 ,(bug-subject* bug))
594 (bug-subject* bug)))
595 (td ,(date->string (bug-date bug)))
596 (td ,(status-tag bug)))))
597 bugs))
598
599 (define (priority-bugs)
600 (list-of-bugs (sort
601 (append
602 (bugs-by-severity "serious" "open")
603 (bugs-by-severity "important" "open"))
604 (lambda (a b) (< (bug-num a) (bug-num b))))))
605
606 (define* (list-of-recent-issues #:optional (max 100))
607 (layout
608 #:body
609 `(,(header #:search-bar? #f)
610 (div
611 (@ (class "container"))
612 (h1 "Recent issues")
613 (table
614 (@ (class "table table-borderless table-hover js-sort-table"))
615 (thead
616 (tr (@ (class "heading"))
617 (th (@ (class "js-sort-number")) "ID")
618 (th "Subject")
619 (th "Date submitted")
620 (th "Status")))
621 (tbody
622 ,@(list-of-bugs (recent-bugs max))))))))
623
624 (define (list-of-matching-bugs query bugs)
625 (layout
626 #:body
627 `(,(header #:search-bar? #f)
628 (div
629 (@ (class "container"))
630 (h1 "Your search for " (code ,query))
631 ,(search-widget #:text query)
632 ,(if (null? bugs)
633 `(div
634 (@ (class "alert alert-warning")
635 (role "alert"))
636 (h4
637 (@ (class "alert-heading"))
638 "Nothing found!")
639 (p "We could not find any issues matching your query "
640 (code ,query) ". "
641 (a (@ (href "/"))
642 "Try searching for something else?")))
643 `(table
644 (@ (class "table table-borderless table-hover js-sort-table"))
645 (thead
646 (tr (@ (class "heading"))
647 (th (@ (class "js-sort-number")) "ID")
648 (th "Subject")
649 (th "Date submitted")
650 (th "Status")))
651 (tbody
652 ,@(list-of-bugs bugs))))))))