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