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