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