40264899f343f2b7932b5d44e391fbcef2d61ab7
[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?20200507"))))
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 issue-details
315 `(span (@ (class "details"))
316 ,(status-tag bug)
317 ,(string-append "Submitted by "
318 ;; We don't use bug-originator here
319 ;; because it includes the email address.
320 ;; We cannot use extract-name on the
321 ;; return value, because it swallows
322 ;; non-ASCII characters.
323 (sender-name (first messages))
324 ".")
325 (details
326 (@ (class "info"))
327 (summary "Details")
328 (dl
329 (@ (class "stat"))
330 ,@(let ((num (length parties)))
331 `((dt ,(if (= num 1)
332 "One participant"
333 (string-append (number->string num)
334 " participants")))
335 (dd
336 (ul ,(map (lambda (name)
337 `(li (span (@ (class "name")))
338 ,name))
339 (map extract-name parties)))))))
340 (dl
341 (@ (class "stat"))
342 (dt "Owner")
343 (dd
344 ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
345 (dl
346 (@ (class "stat"))
347 (dt "Severity")
348 (dd ,(bug-severity bug)))
349 ,@(if (bug-mergedwith bug)
350 `((dl
351 (@ (class "stat"))
352 (dt "Merged with")
353 (dd (ul ,(map (lambda (id)
354 `(li (a (@ (href ,(string-append "/" id)))
355 ,id)))
356 ;; XXX: This field can either hold a
357 ;; string of multiple ids, or a single
358 ;; number. Deal with this mess.
359 (match (bug-mergedwith bug)
360 ((? string? str)
361 (string-split str #\space))
362 ((? number? n)
363 (list (number->string n)))))))))
364 '())
365 ,@(if (bug-blocks bug)
366 `((dl
367 (@ (class "stat"))
368 (dt "Blocks")
369 (dd (ul ,(map (lambda (id)
370 `(li (a (@ (href ,(string-append "/" 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 `((dl
383 (@ (class "stat"))
384 (dt "Blocked by")
385 (dd (ul ,(map (lambda (id)
386 `(li (a (@ (href ,(string-append "/" id)))
387 ,id)))
388 ;; XXX: This field can either hold a
389 ;; string of multiple ids, or a single
390 ;; number. Deal with this mess.
391 (match (bug-blockedby bug)
392 ((? string? str)
393 (string-split str #\space))
394 ((? number? n)
395 (list (number->string n)))))))))
396 '()))))
397 (define comment-box
398 `(div
399 (@ (class "comment-box"))
400 (a (@ (id "comment")))
401 (div
402 (@ (class "avatar")
403 (style "background-color:#bc80bd")) "?")
404 (div
405 (@ (class "message"))
406 (div
407 (@ (class "card"))
408 ,@(if (mailer-enabled?)
409 `((form
410 (@ (action ,(format #f "/issue/~a/comment"
411 (number->string id)))
412 (enctype "multipart/form-data")
413 (method "POST"))
414 (input (@ (style "display:none")
415 (name "validation")
416 (placeholder "Please leave this empty.")) "")
417 (input (@ (type "hidden")
418 (name "timestamp")
419 (value ,(timestamp!))) "")
420 (div
421 (@ (class "card-header"))
422 (div (@ (class "from"))
423 (input (@ (class "address form-control")
424 (name "from")
425 (required "required")
426 (placeholder "Your name")) "")))
427 (div
428 (@ (class "body card-body"))
429 (textarea (@ (name "text")
430 (required "required")
431 (class "form-control")
432 (placeholder "Please input your comment..."))
433 ""))
434 (div
435 (@ (class "card-footer"))
436 (button (@ (class "btn btn-primary")
437 (type "submit"))
438 "Send"))))
439 `((div
440 (@ (class "card-header"))
441 (div (@ (class "from"))
442 (span (@ (class "address")) "Your comment")))
443 (div
444 (@ (class "body card-body"))
445 (p "Comments via the web interface are not currently
446 supported. To comment on this conversation "
447 (a (@ (href ,(string-append "mailto:"
448 (number->string id) "@" (%config 'debbugs-domain)
449 "?subject=" (bug-subject* bug))))
450 ,(string-append "send email to "
451 (number->string id) "@" (%config 'debbugs-domain)))))))))))
452 (define (show-message message-number message previous-subject)
453 `((div (@ (class "mb-5"))
454 (a (@ (id ,(number->string message-number))))
455 (div
456 (@ (class "avatar")
457 (style ,(string-append "background-color:"
458 (avatar-color (sender-email message)
459 (map extract-email parties)))))
460 ,(string-upcase (string-take (sender-name message) 1)))
461 (div
462 (@ (class "message"))
463 (div
464 (@ (class "card"))
465 (div
466 (@ (class "card-header"))
467 (div
468 (@ (class "from"))
469 (div
470 (@ (class "avatar")
471 (style ,(string-append "background-color:"
472 (avatar-color (sender-email message)
473 (map extract-email parties)))))
474 ,(string-upcase (string-take (sender-name message) 1)))
475 (span (@ (class "address")) ,(sender-name message))
476 " wrote on "
477 (span (@ (class "date"))
478 (a (@ (href ,(string-append "#" (number->string
479 message-number))))
480 ,(date->string (date message)))))
481 ,@(if (string-suffix? previous-subject (subject message))
482 '()
483 `((div (@ (class "subject")) ,(subject message))))
484 (div
485 (@ (class "details"))
486 (div
487 (@ (class "recipients"))
488 (label "Recipients:")
489 ,(map (lambda (address)
490 `(span (@ (class "address")) ,address))
491 (recipients message)))
492 (div
493 (@ (class "message-id"))
494 (label "Message-ID:")
495 ,(message-id message))))
496 (div
497 (@ (class "body card-body"))
498 ,(display-message-body id message-number message)))))
499 ,@(if (closing? message id)
500 '((div
501 (@ (class "row event"))
502 (div
503 (@ (class "col-11 offset-1 text-center"))
504 (div (@ (class "badge badge-primary closed")) "Closed"))))
505 '())))
506
507 (if (null? messages) #f
508 (layout
509 #:title (bug-subject* bug)
510 #:body
511 `(,(header #:title (bug-subject* bug))
512 (div
513 (@ (class "container"))
514 ,@(match flash-message
515 (('error . text)
516 `((div (@ (class "alert alert-danger")
517 (role "alert"))
518 ,text)))
519 (('info . text)
520 `((div (@ (class "alert alert-info")
521 (role "alert"))
522 ,text)))
523 (_ '()))
524 (div
525 (@ (class "title col-12"))
526 (h1 (@ (class "h3")) ,(bug-subject* bug))
527 ,issue-details)
528 (div (@ (class "row"))
529 (div
530 (@ (class "conversation col-12"))
531 ,(let ((msgs (filter (lambda (msg)
532 ;; Ignore messages
533 ;; without body, and
534 ;; internal messages.
535 (and msg
536 (email-body msg)
537 (not (internal-message? msg))))
538 messages)))
539 (map (lambda (message-number msg previous-subject)
540 (show-message message-number msg previous-subject))
541 (iota (length msgs))
542 msgs
543 (cons (bug-subject* bug)
544 (map subject msgs))))
545 ,comment-box)))))))
546
547 (define (list-of-bugs bugs)
548 "Return table rows for all BUGS."
549 (map (lambda (bug)
550 (let ((id (number->string (bug-num bug))))
551 `(tr (@ (class ,(bug-severity bug)))
552 (td ,(or id "-"))
553 (td
554 ,@(if (member (bug-severity bug) '("serious" "important"))
555 `((svg (@ (xmlns"http://www.w3.org/2000/svg")
556 (xmlns:xlink "http://www.w3.org/1999/xlink")
557 (viewBox "0 0 14 16")
558 (version "1.1")
559 (height "1rem")
560 (width "1rem")
561 (aria-hidden "true"))
562 (title ,(bug-severity bug))
563 (path (@ (fill-rule "evenodd")
564 (d "\
565 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
566 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
567 c0-3.14 2.56-5.7 5.7-5.7z\
568 M7 1C3.14 1 0 4.14 0 8\
569 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
570 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
571 '())
572 ,(if id
573 `(a (@ (href ,(string-append "/" id)))
574 ,(bug-subject* bug))
575 (bug-subject* bug)))
576 (td ,(date->string (bug-date bug)))
577 (td ,(status-tag bug)))))
578 bugs))
579
580 (define (priority-bugs)
581 (list-of-bugs (sort
582 (append
583 (bugs-by-severity "serious" "open")
584 (bugs-by-severity "important" "open"))
585 (lambda (a b) (< (bug-num a) (bug-num b))))))
586
587 (define* (list-of-recent-issues #:optional (max 100))
588 (layout
589 #:body
590 `(,(header #:search-bar? #f)
591 (div
592 (@ (class "container"))
593 (h1 "Recent issues")
594 (table
595 (@ (class "table table-borderless table-hover js-sort-table"))
596 (thead
597 (tr (@ (class "heading"))
598 (th (@ (class "js-sort-number")) "ID")
599 (th "Subject")
600 (th "Date submitted")
601 (th "Status")))
602 (tbody
603 ,@(list-of-bugs (recent-bugs max))))))))
604
605 (define (list-of-matching-bugs query bugs)
606 (layout
607 #:body
608 `(,(header #:search-bar? #f)
609 (div
610 (@ (class "container"))
611 (h1 "Your search for " (code ,query))
612 ,(search-widget #:text query)
613 ,(if (null? bugs)
614 `(div
615 (@ (class "alert alert-warning")
616 (role "alert"))
617 (h4
618 (@ (class "alert-heading"))
619 "Nothing found!")
620 (p "We could not find any issues matching your query "
621 (code ,query) ". "
622 (a (@ (href "/"))
623 "Try searching for something else?")))
624 `(table
625 (@ (class "table table-borderless table-hover js-sort-table"))
626 (thead
627 (tr (@ (class "heading"))
628 (th (@ (class "js-sort-number")) "ID")
629 (th "Subject")
630 (th "Date submitted")
631 (th "Status")))
632 (tbody
633 ,@(list-of-bugs bugs))))))))