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