Let issue-page display an optional flash message.
[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 (ice-9 match)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-19)
28 #:export (index
29 help
30 unknown
31 error-page
32 issue-page
33 list-of-matching-bugs))
34
35 (define (bug-subject* bug)
36 (or (bug-subject bug) "(no subject)"))
37
38 (define (status-tag bug)
39 "Return a colored tag indicating the BUG status."
40 (let ((status (if (bug-done bug) "Done" "Open")))
41 `(span (@ (class ,(string-append "status-tag "
42 (string-downcase status))))
43 ,status)))
44
45 (define* (layout #:key
46 (head '())
47 (body '())
48 (title "Guix issue tracker")
49 (extra-headers '()))
50 `(#:sxml ((doctype "html")
51 (html
52 (head
53 (title ,title)
54 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
55 (meta (@ (http-equiv "Content-Language") (content "en")))
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 (@ (type "text/javascript")
90 (src "/js/sort-table.js")))))
91 #:extra-headers ,extra-headers))
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 #:extra-headers
174 '((cache-control . ((max-age . 60))))
175 #:body
176 `(,(header #:search-bar? #f)
177 (main
178 (@ (class "container"))
179 (h1 "Guix issue tracker")
180 (p (@ (class "lead"))
181 "This is a web frontend to the Guix patch and bug trackers. Send email to "
182 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
183 ,(%config 'submission-email-address))
184 " to submit a patch, or email "
185 (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
186 ,(%config 'submission-bug-email-address))
187 " to submit a bug report.")
188 ,(search-widget)
189
190 (div (@ (class "mt-4 h4")) "Recent activity")
191 (table
192 (@ (class "table table-borderless table-hover js-sort-table"))
193 (thead
194 (tr (@ (class "heading"))
195 (th (@ (class "js-sort-number")) "ID")
196 (th "Subject")
197 (th "Date submitted")
198 (th "Status")))
199 (tbody
200 ,@(list-of-bugs (recent-bugs 10))))
201
202 (div (@ (class "mt-4 h4")) "Priority bugs")
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 ,@(priority-bugs)))))))
213
214 (define (help)
215 (layout
216 #:extra-headers
217 ;; Cache for 24 hours.
218 '((cache-control . ((max-age . 86400))))
219 #:body
220 `(,(header #:search-bar? #f)
221 (div
222 (@ (class "container"))
223 (h1 "Help")
224 (a (@ (href "search")))
225 (p "You can improve the search results by making use of the
226 simple query language. Here is a list of supported query terms with
227 some examples.")
228 (table
229 (@ (class "table"))
230 (thead
231 (tr
232 (th (@ (class "col-md-3")) "Filter")
233 (th (@ (class "col-md-9")) "Description")))
234 (tbody
235 (tr
236 (td (span (@ (class "filter")) "is:open") ", "
237 (span (@ (class "filter")) "is:pending"))
238 (td "Open issues."))
239 (tr
240 (td (span (@ (class "filter")) "is:closed") ", "
241 (span (@ (class "filter")) "is:done"))
242 (td "Issues marked as done."))
243 (tr
244 (td (span (@ (class "filter")) "submitter:<who>"))
245 (td "Issues submitted by a person named " (strong "who")
246 ", e.g. "
247 (span (@ (class "filter")) "submitter:ludo")
248 " for all issues submitted by ludo. "
249 "The filter matches both the email address and the name."))
250 (tr
251 (td (span (@ (class "filter")) "author:<who>"))
252 (td "Issues where a person named " (strong "who")
253 " has commented, e.g. "
254 (span (@ (class "filter")) "author:rekado")
255 " for all messages where rekado has commented. "
256 "The filter matches both the email address and the name."))
257 (tr
258 (td (span (@ (class "filter")) "date:<start>..<end>"))
259 (td "Issues or comments submitted within the provided range. "
260 (strong "start") " and " (strong "end") " can be one of "
261 (strong "now") ", " (strong "today")
262 ", a date in the formats "
263 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
264 ", or an amount and a unit for a point in the past, such as "
265 (strong "12d..") " for 12 days ago. "
266 "Supported units are: "
267 (strong "h") " (hours), "
268 (strong "d") " (days), "
269 (strong "w") " (weeks), "
270 (strong "m") " (months), and "
271 (strong "y") " (years)."))))))))
272
273 (define (unknown id)
274 (layout
275 #:body
276 `(,(header)
277 (div (@ (class "container"))
278 (h1 "Patch not found")
279 (p "There is no submission with id " (strong ,id))
280 (p (a (@ (href "/")) "Try another one?"))))))
281
282 (define (error-page message)
283 (layout
284 #:body
285 `(,(header)
286 (div (@ (class "container"))
287 (h1 "Error")
288 (p "An error occurred. Sorry about that!")
289 ,message
290 (p (a (@ (href "/")) "Try something else?"))))))
291
292 (define* (issue-page bug #:optional flash-message)
293 "Render the conversation for the given BUG."
294 (define id (bug-num bug))
295 (define messages (patch-messages id))
296 (define parties (sort (filter (compose (negate bot?) extract-email)
297 (participants (filter identity messages)))
298 (lambda (a b)
299 (string< (extract-email a)
300 (extract-email b)))))
301 (define (show-message message-number message previous-subject)
302 `((div (@ (class "mb-5"))
303 (a (@ (id ,(number->string message-number))))
304 (div
305 (@ (class "avatar")
306 (style ,(string-append "background-color:"
307 (avatar-color (sender-email message)
308 (map extract-email parties)))))
309 ,(string-upcase (string-take (sender-name message) 1)))
310 (div
311 (@ (class "message"))
312 (div
313 (@ (class "card"))
314 (div
315 (@ (class "card-header"))
316 (div
317 (@ (class "from"))
318 (div
319 (@ (class "avatar")
320 (style ,(string-append "background-color:"
321 (avatar-color (sender-email message)
322 (map extract-email parties)))))
323 ,(string-upcase (string-take (sender-name message) 1)))
324 (span (@ (class "address")) ,(sender-name message))
325 " wrote on "
326 (span (@ (class "date"))
327 (a (@ (href ,(string-append "#" (number->string
328 message-number))))
329 ,(date->string (date message)))))
330 ,@(if (string-suffix? previous-subject (subject message))
331 '()
332 `((div (@ (class "subject")) ,(subject message))))
333 (div
334 (@ (class "details"))
335 (div
336 (@ (class "recipients"))
337 (label "Recipients:")
338 ,(map (lambda (address)
339 `(span (@ (class "address")) ,address))
340 (recipients message)))
341 (div
342 (@ (class "message-id"))
343 (label "Message-ID:")
344 ,(message-id message))))
345 (div
346 (@ (class "body card-body"))
347 ,(display-message-body id message-number message)))))
348 ,@(if (closing? message id)
349 '((div
350 (@ (class "row event"))
351 (div
352 (@ (class "col-md-11 offset-md-1 text-center"))
353 (div (@ (class "badge badge-primary closed")) "Closed"))))
354 '())))
355 (layout
356 #:title (bug-subject* bug)
357 #:extra-headers
358 (cond
359 ((bug-archived bug)
360 ;; Tell browser to cache this for 12 hours.
361 '((cache-control . ((max-age . 43200)))))
362 ((bug-done bug)
363 ;; Tell browser to cache this for 1 hour.
364 '((cache-control . ((max-age . 3600)))))
365 (else '()))
366 #:body
367 `(,(header)
368 (div
369 (@ (class "container"))
370 ,@(match flash-message
371 (('error . text)
372 `((div (@ (class "alert alert-danger")
373 (role "alert"))
374 ,text)))
375 (('info . text)
376 `((div (@ (class "alert alert-info")
377 (role "alert"))
378 ,text)))
379 (_ '()))
380 (div
381 (@ (class "title col-md-12"))
382 (h1 ,(bug-subject* bug))
383 (span (@ (class "details"))
384 ,(status-tag bug)
385 ,(string-append "Submitted by "
386 ;; We don't use bug-originator here
387 ;; because it includes the email address.
388 ;; We cannot use extract-name on the
389 ;; return value, because it swallows
390 ;; non-ASCII characters.
391 (sender-name (first messages))
392 ".")
393 ,@(if (bug-mergedwith bug)
394 `((ul (@ (class "merged"))
395 "Merged with: "
396 ,(map (lambda (id)
397 `(li (a (@ (href ,(string-append "/issue/" id)))
398 ,id)))
399 ;; XXX: This field can either hold a
400 ;; string of multiple ids, or a single
401 ;; number. Deal with this mess.
402 (match (bug-mergedwith bug)
403 ((? string? str)
404 (string-split str #\space))
405 ((? number? n)
406 (list (number->string n)))))))
407 '())
408 ,@(if (bug-blocks bug)
409 `((ul (@ (class "blocks"))
410 "Blocks: "
411 ,(map (lambda (id)
412 `(li (a (@ (href ,(string-append "/issue/" id)))
413 ,id)))
414 ;; XXX: This field can either hold a
415 ;; string of multiple ids, or a single
416 ;; number. Deal with this mess.
417 (match (bug-blocks bug)
418 ((? string? str)
419 (string-split str #\space))
420 ((? number? n)
421 (list (number->string n)))))))
422 '())
423 ,@(if (bug-blockedby bug)
424 `((ul (@ (class "blockedby"))
425 "Blocked by: "
426 ,(map (lambda (id)
427 `(li (a (@ (href ,(string-append "/issue/" id)))
428 ,id)))
429 ;; XXX: This field can either hold a
430 ;; string of multiple ids, or a single
431 ;; number. Deal with this mess.
432 (match (bug-blockedby bug)
433 ((? string? str)
434 (string-split str #\space))
435 ((? number? n)
436 (list (number->string n)))))))
437 '())))
438 (div (@ (class "row"))
439 (div
440 (@ (class "conversation col-md-9"))
441 ,(let ((msgs (filter (lambda (msg)
442 ;; Ignore messages
443 ;; without body, and
444 ;; internal messages.
445 (and msg
446 (email-body msg)
447 (not (internal-message? msg))))
448 messages)))
449 (map (lambda (message-number msg previous-subject)
450 (show-message message-number msg previous-subject))
451 (iota (length msgs))
452 msgs
453 (cons (bug-subject* bug)
454 (map subject msgs))))
455 (div
456 (@ (class "comment-box"))
457 (a (@ (id "comment")))
458 (div
459 (@ (class "avatar")
460 (style "background-color:#bc80bd")) "?")
461 (div
462 (@ (class "message"))
463 (div
464 (@ (class "card"))
465 (div
466 (@ (class "card-header"))
467 (div (@ (class "from"))
468 (span (@ (class "address")) "Your comment")))
469 (div
470 (@ (class "body card-body"))
471 (p "Comments via the web interface are not currently
472 supported. To comment on this conversation "
473 (a (@ (href ,(string-append "mailto:"
474 (number->string id) "@" (%config 'debbugs-domain)
475 "?subject=" (bug-subject* bug))))
476 ,(string-append "send email to "
477 (number->string id) "@" (%config 'debbugs-domain)))))))))
478
479 (div
480 (@ (class "info col-md-3"))
481 (dl
482 (@ (class "stat"))
483 ,@(let ((num (length parties)))
484 `((dt ,(if (= num 1)
485 "One participant"
486 (string-append (number->string num)
487 " participants")))
488 (dd
489 (ul ,(map (lambda (name)
490 `(li (span (@ (class "name")))
491 ,name))
492 (map extract-name parties)))))))
493 (dl
494 (@ (class "stat"))
495 (dt "Owner")
496 (dd
497 ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
498 (dl
499 (@ (class "stat"))
500 (dt "Severity")
501 (dd ,(bug-severity bug)))
502 (dl
503 (@ (class "stat"))
504 (dt "Status")
505 (dd ,(status-tag bug)))))))))
506
507 (define (list-of-bugs bugs)
508 "Return table rows for all BUGS."
509 (map (lambda (bug)
510 (let ((id (number->string (bug-num bug))))
511 `(tr (@ (class ,(bug-severity bug)))
512 (td ,(or id "-"))
513 (td
514 ,@(if (member (bug-severity bug) '("serious" "important"))
515 `((svg (@ (xmlns"http://www.w3.org/2000/svg")
516 (xmlns:xlink "http://www.w3.org/1999/xlink")
517 (viewBox "0 0 14 16")
518 (version "1.1")
519 (height "1rem")
520 (width "1rem")
521 (aria-hidden "true"))
522 (title ,(bug-severity bug))
523 (path (@ (fill-rule "evenodd")
524 (d "\
525 M7 2.3c3.14 0 5.7 2.56 5.7 5.7\
526 s-2.56 5.7-5.7 5.7A5.71 5.71 0 011.3 8\
527 c0-3.14 2.56-5.7 5.7-5.7z\
528 M7 1C3.14 1 0 4.14 0 8\
529 s3.14 7 7 7 7-3.14 7-7-3.14-7-7-7z\
530 m1 3H6v5h2V4zm0 6H6v2h2v-2z")))))
531 '())
532 ,(if id
533 `(a (@ (href ,(string-append "/issue/" id)))
534 ,(bug-subject* bug))
535 (bug-subject* bug)))
536 (td ,(date->string (bug-date bug)))
537 (td ,(status-tag bug)))))
538 bugs))
539
540 (define (priority-bugs)
541 (list-of-bugs (sort
542 (append
543 (bugs-by-severity "serious" "open")
544 (bugs-by-severity "important" "open"))
545 (lambda (a b) (< (bug-num a) (bug-num b))))))
546
547 (define (list-of-matching-bugs query bugs)
548 (layout
549 #:body
550 `(,(header #:search-bar? #f)
551 (div
552 (@ (class "container"))
553 (h1 "Your search for " (code ,query))
554 ,(search-widget #:text query)
555 ,(if (null? bugs)
556 `(div
557 (@ (class "alert alert-warning")
558 (role "alert"))
559 (h4
560 (@ (class "alert-heading"))
561 "Nothing found!")
562 (p "We could not find any issues matching your query "
563 (code ,query) ". "
564 (a (@ (href "/"))
565 "Try searching for something else?")))
566 `(table
567 (@ (class "table table-borderless table-hover js-sort-table"))
568 (thead
569 (tr (@ (class "heading"))
570 (th (@ (class "js-sort-number")) "ID")
571 (th "Subject")
572 (th "Date submitted")
573 (th "Status")))
574 (tbody
575 ,@(list-of-bugs bugs))))))))