03b701adffa0c5aadd2af6811ce98c9479b6c865
[software/mumi.git] / mumi / web / view / html.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019 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 #:extra-headers ,extra-headers))
89
90 (define* (search-form #:key (standalone? #f))
91 `(form (@ (id "search")
92 ,(if standalone?
93 '(class "")
94 '(class "form-inline"))
95 (action "/search"))
96 (div
97 (@ (class ,(if standalone?
98 "input-group input-group-lg"
99 "input-group")))
100 (input (@ (type "text")
101 (class "form-control")
102 (id "query")
103 (name "query")
104 (placeholder "input search query")))
105 (span (@ (class "input-group-append"))
106 (button
107 (@ (type "submit")
108 (class ,(string-append (if standalone? "btn-lg " "")
109 "btn btn-primary")))
110 "Search")))))
111
112 (define* (header #:key (search-bar? #t))
113 `(nav
114 (@ (class "navbar navbar-expand navbar-light bg-light"))
115 (a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
116 (img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
117 ,@(if search-bar?
118 `(,(search-form))
119 '())))
120
121 (define (index)
122 (layout
123 #:extra-headers
124 '((cache-control . ((max-age . 60))))
125 #:body
126 `(,(header #:search-bar? #f)
127 (main
128 (@ (class "container"))
129 (h1 "Guix patch tracker")
130 (p (@ (class "lead"))
131 "This is a web frontend to the Guix issue trackers. Send email to "
132 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
133 ,(%config 'submission-email-address))
134 " to submit your patches or email "
135 (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
136 ,(%config 'submission-bug-email-address))
137 " to open a new issue.")
138 (div
139 (@ (class "card mb-5"))
140 (div (@ (class "card-body bg-light"))
141 ,(search-form #:standalone? #t)
142 (p (@ (class "card-text"))
143 (strong "Hint: ")
144 "Refine your search with filters like "
145 (span (@ (class "filter"))
146 "is:open")
147 ", "
148 (span (@ (class "filter"))
149 "author:me")
150 ", "
151 (span (@ (class "filter"))
152 "submitter:me")
153 ", "
154 (span (@ (class "filter"))
155 "date:yesterday..now")
156 ", "
157 (span (@ (class "filter"))
158 "date:2018-04-01..2018-04-02")
159 ", "
160 (span (@ (class "filter"))
161 "date:1m..today")
162 ", and "
163 (a (@ (href "help#search"))
164 "many more!"))))
165 (h1 "Issues of interest")
166 (table (@ (class "table table-condensed table-sm table-hover"))
167 (thead
168 (tr (th "ID")
169 (th "Subject")
170 (th "Date submitted")
171 (th "Status")))
172 (tbody
173 (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Recent activity"))
174 ,@(list-of-bugs (recent-bugs 10))
175 (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Priority bugs"))
176 ,@(priority-bugs)))))))
177
178 (define (help)
179 (layout
180 #:extra-headers
181 ;; Cache for 24 hours.
182 '((cache-control . ((max-age . 86400))))
183 #:body
184 `(,(header #:search-bar? #f)
185 (div
186 (@ (class "container"))
187 (h1 "Help")
188 (a (@ (href "search")))
189 (p "You can improve the search results by making use of the
190 simple query language. Here is a list of supported query terms with
191 some examples.")
192 (table
193 (@ (class "table"))
194 (thead
195 (tr
196 (th (@ (class "col-md-3")) "Filter")
197 (th (@ (class "col-md-9")) "Description")))
198 (tbody
199 (tr
200 (td (span (@ (class "filter")) "is:open") ", "
201 (span (@ (class "filter")) "is:pending"))
202 (td "Open issues."))
203 (tr
204 (td (span (@ (class "filter")) "is:closed") ", "
205 (span (@ (class "filter")) "is:done"))
206 (td "Issues marked as done."))
207 (tr
208 (td (span (@ (class "filter")) "submitter:<who>"))
209 (td "Issues submitted by a person named " (strong "who")
210 ", e.g. "
211 (span (@ (class "filter")) "submitter:ludo")
212 " for all issues submitted by ludo. "
213 "The filter matches both the email address and the name."))
214 (tr
215 (td (span (@ (class "filter")) "author:<who>"))
216 (td "Issues where a person named " (strong "who")
217 " has commented, e.g. "
218 (span (@ (class "filter")) "author:rekado")
219 " for all messages where rekado has commented. "
220 "The filter matches both the email address and the name."))
221 (tr
222 (td (span (@ (class "filter")) "date:<start>..<end>"))
223 (td "Issues or comments submitted within the provided range. "
224 (strong "start") " and " (strong "end") " can be one of "
225 (strong "now") ", " (strong "today") ", " (strong "yesterday")
226 ", a date in the formats "
227 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
228 ", or an amount and a unit for a point in the past, such as "
229 (strong "12d") " for 12 days ago. "
230 "Supported units are: "
231 (strong "h") " (hours), "
232 (strong "d") " (days), "
233 (strong "w") " (weeks), "
234 (strong "m") " (months), and "
235 (strong "y") " (years)."))))))))
236
237 (define (unknown id)
238 (layout
239 #:body
240 `(,(header)
241 (div (@ (class "container"))
242 (h1 "Patch not found")
243 (p "There is no submission with id " (strong ,id))
244 (p (a (@ (href "/")) "Try another one?"))))))
245
246 (define (error-page message)
247 (layout
248 #:body
249 `(,(header)
250 (div (@ (class "container"))
251 (h1 "Error")
252 (p "An error occurred. Sorry about that!")
253 ,message
254 (p (a (@ (href "/")) "Try something else?"))))))
255
256 (define (issue-page bug)
257 "Render the conversation for the given BUG."
258 (define id (bug-num bug))
259 (define messages (patch-messages id))
260 (define parties (sort (filter (compose (negate bot?) extract-email)
261 (participants messages))
262 (lambda (a b)
263 (string< (extract-email a)
264 (extract-email b)))))
265 (define (show-message message-number message previous-subject)
266 `((div (@ (class "mb-5"))
267 (a (@ (id ,(number->string message-number))))
268 (div
269 (@ (class "avatar")
270 (style ,(string-append "background-color:"
271 (avatar-color (sender-email message)
272 (map extract-email parties)))))
273 ,(string-upcase (string-take (sender-name message) 1)))
274 (div
275 (@ (class "message"))
276 (div
277 (@ (class "card"))
278 (div
279 (@ (class "card-header"))
280 (div
281 (@ (class "from"))
282 (div
283 (@ (class "avatar")
284 (style ,(string-append "background-color:"
285 (avatar-color (sender-email message)
286 (map extract-email parties)))))
287 ,(string-upcase (string-take (sender-name message) 1)))
288 (span (@ (class "address")) ,(sender-name message))
289 " wrote on "
290 (span (@ (class "date"))
291 (a (@ (href ,(string-append "#" (number->string
292 message-number))))
293 ,(date->string (date message)))))
294 ,@(if (string-suffix? previous-subject (subject message))
295 '()
296 `((div (@ (class "subject")) ,(subject message))))
297 (div
298 (@ (class "details"))
299 (div
300 (@ (class "recipients"))
301 (label "Recipients:")
302 ,(map (lambda (address)
303 `(span (@ (class "address")) ,address))
304 (recipients message)))
305 (div
306 (@ (class "message-id"))
307 (label "Message-ID:")
308 ,(message-id message))))
309 (div
310 (@ (class "body card-body"))
311 ,(display-message-body id message-number message)))))
312 ,@(if (closing? message id)
313 '((div
314 (@ (class "row event"))
315 (div
316 (@ (class "col-md-11 offset-md-1 text-center"))
317 (div (@ (class "badge badge-primary closed")) "Closed"))))
318 '())))
319 (layout
320 #:title (bug-subject* bug)
321 #:extra-headers
322 (cond
323 ((bug-archived bug)
324 ;; Tell browser to cache this for 12 hours.
325 '((cache-control . ((max-age . 43200)))))
326 ((bug-done bug)
327 ;; Tell browser to cache this for 1 hour.
328 '((cache-control . ((max-age . 3600)))))
329 (else '()))
330 #:body
331 `(,(header)
332 (div
333 (@ (class "container"))
334 (div
335 (@ (class "title col-md-12"))
336 (h1 ,(bug-subject* bug))
337 (span (@ (class "details"))
338 ,(status-tag bug)
339 ,(string-append "Submitted by "
340 ;; We don't use bug-originator here
341 ;; because it includes the email address.
342 ;; We cannot use extract-name on the
343 ;; return value, because it swallows
344 ;; non-ASCII characters.
345 (sender-name (first messages))
346 ".")
347 ,@(if (bug-mergedwith bug)
348 `((ul (@ (class "merged"))
349 "Merged with: "
350 ,(map (lambda (id)
351 `(li (a (@ (href ,(string-append "/issue/" id)))
352 ,id)))
353 ;; XXX: This field can either hold a
354 ;; string of multiple ids, or a single
355 ;; number. Deal with this mess.
356 (match (bug-mergedwith bug)
357 ((? string? str)
358 (string-split str #\space))
359 ((? number? n)
360 (list (number->string n)))))))
361 '())
362 ,@(if (bug-blocks bug)
363 `((ul (@ (class "blocks"))
364 "Blocks: "
365 ,(map (lambda (id)
366 `(li (a (@ (href ,(string-append "/issue/" id)))
367 ,id)))
368 ;; XXX: This field can either hold a
369 ;; string of multiple ids, or a single
370 ;; number. Deal with this mess.
371 (match (bug-blocks bug)
372 ((? string? str)
373 (string-split str #\space))
374 ((? number? n)
375 (list (number->string n)))))))
376 '())
377 ,@(if (bug-blockedby bug)
378 `((ul (@ (class "blockedby"))
379 "Blocked by: "
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-blockedby bug)
387 ((? string? str)
388 (string-split str #\space))
389 ((? number? n)
390 (list (number->string n)))))))
391 '())))
392 (div (@ (class "row"))
393 (div
394 (@ (class "conversation col-md"))
395 ,(let ((msgs (filter (lambda (msg)
396 ;; Ignore messages
397 ;; without body, and
398 ;; internal messages.
399 (and (email-body msg)
400 (not (internal-message? msg))))
401 messages)))
402 (map (lambda (message-number msg previous-subject)
403 (show-message message-number msg previous-subject))
404 (iota (length msgs))
405 msgs
406 (cons (bug-subject* bug)
407 (map subject msgs))))
408 (div
409 (@ (class "comment-box"))
410 (a (@ (id "comment")))
411 (div
412 (@ (class "avatar")
413 (style "background-color:#bc80bd")) "?")
414 (div
415 (@ (class "message"))
416 (div
417 (@ (class "card"))
418 (div
419 (@ (class "card-header"))
420 (div (@ (class "from"))
421 (span (@ (class "address")) "Your comment")))
422 (div
423 (@ (class "body card-body"))
424 (p "Comments via the web interface are not currently
425 supported. To comment on this conversation "
426 (a (@ (href ,(string-append "mailto:"
427 (number->string id) "@" (%config 'debbugs-domain)
428 "?subject=" (bug-subject* bug))))
429 ,(string-append "send email to "
430 (number->string id) "@" (%config 'debbugs-domain)))))))))
431
432 (div
433 (@ (class "info col-md-3"))
434 (dl
435 (@ (class "stat"))
436 ,@(let ((num (length parties)))
437 `((dt ,(if (= num 1)
438 "One participant"
439 (string-append (number->string num)
440 " participants")))
441 (dd
442 (ul ,(map (lambda (name)
443 `(li (span (@ (class "name")))
444 ,name))
445 (map extract-name parties)))))))
446 (dl
447 (@ (class "stat"))
448 (dt "Owner")
449 (dd
450 ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
451 (dl
452 (@ (class "stat"))
453 (dt "Severity")
454 (dd ,(bug-severity bug)))
455 (dl
456 (@ (class "stat"))
457 (dt "Status")
458 (dd ,(status-tag bug)))))))))
459
460 (define (list-of-bugs bugs)
461 "Return table rows for all BUGS."
462 (map (lambda (bug)
463 (let ((id (number->string (bug-num bug))))
464 `(tr (@ (class ,(bug-severity bug)))
465 (td ,(or id "-"))
466 (td ,(if id
467 `(a (@ (href ,(string-append "/issue/" id)))
468 ,(bug-subject* bug))
469 (bug-subject* bug)))
470 (td ,(date->string (bug-date bug)))
471 (td ,(status-tag bug)))))
472 bugs))
473
474 (define (priority-bugs)
475 (list-of-bugs (sort
476 (append
477 (bugs-by-severity "serious" "open")
478 (bugs-by-severity "important" "open"))
479 (lambda (a b) (< (bug-num a) (bug-num b))))))
480
481 (define (list-of-matching-bugs query bugs)
482 (layout
483 #:body
484 `(,(header)
485 (div (@ (class "container"))
486 ,@(if (null? bugs)
487 `((h1 "No issues found")
488 (p "We could not find any issues matching your query "
489 (code ,query) ". "
490 (a (@ (href "/"))
491 "Try searching for something else?")))
492 `((h1 "Submissions matching " (code ,query))
493 (table (@ (class "table table-condensed table-sm table-hover"))
494 (thead
495 (tr (th "ID")
496 (th "Subject")
497 (th "Date submitted")
498 (th "Status")))
499 (tbody
500 ,@(list-of-bugs bugs)))))))))