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