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