view/html: Capitalize placeholder.
[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 your 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 ;; This SVG is part of Bootstrap and is available
111 ;; under the Expat license.
112 (svg
113 (@ (class "bi bi-search")
114 (width "1em")
115 (height "1em")
116 (viewBox "0 0 16 16")
117 (fill "currentColor")
118 (xmlns "http://www.w3.org/2000/svg"))
119 (title "Search")
120 (path (@ (fill-rule "evenodd")
121 (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")
122 (clip-rule "evenodd")) "")
123 (path (@ (fill-rule "evenodd")
124 (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")
125 (clip-rule "evenodd")) "")))))))
126
127 (define* (header #:key (search-bar? #t))
128 `(nav
129 (@ (class "navbar navbar-expand navbar-light bg-light"))
130 (a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
131 (img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
132 ,@(if search-bar?
133 `(,(search-form))
134 '())))
135
136 (define (index)
137 (layout
138 #:extra-headers
139 '((cache-control . ((max-age . 60))))
140 #:body
141 `(,(header #:search-bar? #f)
142 (main
143 (@ (class "container"))
144 (h1 "Guix patch tracker")
145 (p (@ (class "lead"))
146 "This is a web frontend to the Guix issue trackers. Send email to "
147 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
148 ,(%config 'submission-email-address))
149 " to submit your patches or email "
150 (a (@ (href ,(string-append "mailto:" (%config 'submission-bug-email-address))))
151 ,(%config 'submission-bug-email-address))
152 " to open a new issue.")
153 (div
154 (@ (class "card mb-5"))
155 (div (@ (class "card-body bg-light"))
156 ,(search-form #:standalone? #t)
157 (p (@ (class "card-text"))
158 (strong "Hint: ")
159 "Refine your search with filters like "
160 (span (@ (class "filter"))
161 "is:open")
162 ", "
163 (span (@ (class "filter"))
164 "author:me")
165 ", "
166 (span (@ (class "filter"))
167 "submitter:me")
168 ", "
169 (span (@ (class "filter"))
170 "date:yesterday..now")
171 ", "
172 (span (@ (class "filter"))
173 "date:2018-04-01..2018-04-02")
174 ", "
175 (span (@ (class "filter"))
176 "date:1m..today")
177 ", and "
178 (a (@ (href "help#search"))
179 "many more!"))))
180 (h1 "Issues of interest")
181 (table (@ (class "table table-condensed table-sm table-hover"))
182 (thead
183 (tr (th "ID")
184 (th "Subject")
185 (th "Date submitted")
186 (th "Status")))
187 (tbody
188 (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Recent activity"))
189 ,@(list-of-bugs (recent-bugs 10))
190 (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Priority bugs"))
191 ,@(priority-bugs)))))))
192
193 (define (help)
194 (layout
195 #:extra-headers
196 ;; Cache for 24 hours.
197 '((cache-control . ((max-age . 86400))))
198 #:body
199 `(,(header #:search-bar? #f)
200 (div
201 (@ (class "container"))
202 (h1 "Help")
203 (a (@ (href "search")))
204 (p "You can improve the search results by making use of the
205 simple query language. Here is a list of supported query terms with
206 some examples.")
207 (table
208 (@ (class "table"))
209 (thead
210 (tr
211 (th (@ (class "col-md-3")) "Filter")
212 (th (@ (class "col-md-9")) "Description")))
213 (tbody
214 (tr
215 (td (span (@ (class "filter")) "is:open") ", "
216 (span (@ (class "filter")) "is:pending"))
217 (td "Open issues."))
218 (tr
219 (td (span (@ (class "filter")) "is:closed") ", "
220 (span (@ (class "filter")) "is:done"))
221 (td "Issues marked as done."))
222 (tr
223 (td (span (@ (class "filter")) "submitter:<who>"))
224 (td "Issues submitted by a person named " (strong "who")
225 ", e.g. "
226 (span (@ (class "filter")) "submitter:ludo")
227 " for all issues submitted by ludo. "
228 "The filter matches both the email address and the name."))
229 (tr
230 (td (span (@ (class "filter")) "author:<who>"))
231 (td "Issues where a person named " (strong "who")
232 " has commented, e.g. "
233 (span (@ (class "filter")) "author:rekado")
234 " for all messages where rekado has commented. "
235 "The filter matches both the email address and the name."))
236 (tr
237 (td (span (@ (class "filter")) "date:<start>..<end>"))
238 (td "Issues or comments submitted within the provided range. "
239 (strong "start") " and " (strong "end") " can be one of "
240 (strong "now") ", " (strong "today") ", " (strong "yesterday")
241 ", a date in the formats "
242 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
243 ", or an amount and a unit for a point in the past, such as "
244 (strong "12d") " for 12 days ago. "
245 "Supported units are: "
246 (strong "h") " (hours), "
247 (strong "d") " (days), "
248 (strong "w") " (weeks), "
249 (strong "m") " (months), and "
250 (strong "y") " (years)."))))))))
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 "mb-5"))
282 (a (@ (id ,(number->string message-number))))
283 (div
284 (@ (class "avatar")
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"))
291 (div
292 (@ (class "card"))
293 (div
294 (@ (class "card-header"))
295 (div
296 (@ (class "from"))
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 (span (@ (class "address")) ,(sender-name message))
304 " wrote on "
305 (span (@ (class "date"))
306 (a (@ (href ,(string-append "#" (number->string
307 message-number))))
308 ,(date->string (date message)))))
309 ,@(if (string-suffix? previous-subject (subject message))
310 '()
311 `((div (@ (class "subject")) ,(subject message))))
312 (div
313 (@ (class "details"))
314 (div
315 (@ (class "recipients"))
316 (label "Recipients:")
317 ,(map (lambda (address)
318 `(span (@ (class "address")) ,address))
319 (recipients message)))
320 (div
321 (@ (class "message-id"))
322 (label "Message-ID:")
323 ,(message-id message))))
324 (div
325 (@ (class "body card-body"))
326 ,(display-message-body id message-number message)))))
327 ,@(if (closing? message id)
328 '((div
329 (@ (class "row event"))
330 (div
331 (@ (class "col-md-11 offset-md-1 text-center"))
332 (div (@ (class "badge badge-primary closed")) "Closed"))))
333 '())))
334 (layout
335 #:title (bug-subject* bug)
336 #:extra-headers
337 (cond
338 ((bug-archived bug)
339 ;; Tell browser to cache this for 12 hours.
340 '((cache-control . ((max-age . 43200)))))
341 ((bug-done bug)
342 ;; Tell browser to cache this for 1 hour.
343 '((cache-control . ((max-age . 3600)))))
344 (else '()))
345 #:body
346 `(,(header)
347 (div
348 (@ (class "container"))
349 (div
350 (@ (class "title col-md-12"))
351 (h1 ,(bug-subject* bug))
352 (span (@ (class "details"))
353 ,(status-tag bug)
354 ,(string-append "Submitted by "
355 ;; We don't use bug-originator here
356 ;; because it includes the email address.
357 ;; We cannot use extract-name on the
358 ;; return value, because it swallows
359 ;; non-ASCII characters.
360 (sender-name (first messages))
361 ".")
362 ,@(if (bug-mergedwith bug)
363 `((ul (@ (class "merged"))
364 "Merged with: "
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-mergedwith bug)
372 ((? string? str)
373 (string-split str #\space))
374 ((? number? n)
375 (list (number->string n)))))))
376 '())
377 ,@(if (bug-blocks bug)
378 `((ul (@ (class "blocks"))
379 "Blocks: "
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-blocks bug)
387 ((? string? str)
388 (string-split str #\space))
389 ((? number? n)
390 (list (number->string n)))))))
391 '())
392 ,@(if (bug-blockedby bug)
393 `((ul (@ (class "blockedby"))
394 "Blocked by: "
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-blockedby bug)
402 ((? string? str)
403 (string-split str #\space))
404 ((? number? n)
405 (list (number->string n)))))))
406 '())))
407 (div (@ (class "row"))
408 (div
409 (@ (class "conversation col-md"))
410 ,(let ((msgs (filter (lambda (msg)
411 ;; Ignore messages
412 ;; without body, and
413 ;; internal messages.
414 (and (email-body msg)
415 (not (internal-message? msg))))
416 messages)))
417 (map (lambda (message-number msg previous-subject)
418 (show-message message-number msg previous-subject))
419 (iota (length msgs))
420 msgs
421 (cons (bug-subject* bug)
422 (map subject msgs))))
423 (div
424 (@ (class "comment-box"))
425 (a (@ (id "comment")))
426 (div
427 (@ (class "avatar")
428 (style "background-color:#bc80bd")) "?")
429 (div
430 (@ (class "message"))
431 (div
432 (@ (class "card"))
433 (div
434 (@ (class "card-header"))
435 (div (@ (class "from"))
436 (span (@ (class "address")) "Your comment")))
437 (div
438 (@ (class "body card-body"))
439 (p "Comments via the web interface are not currently
440 supported. To comment on this conversation "
441 (a (@ (href ,(string-append "mailto:"
442 (number->string id) "@" (%config 'debbugs-domain)
443 "?subject=" (bug-subject* bug))))
444 ,(string-append "send email to "
445 (number->string id) "@" (%config 'debbugs-domain)))))))))
446
447 (div
448 (@ (class "info col-md-3"))
449 (dl
450 (@ (class "stat"))
451 ,@(let ((num (length parties)))
452 `((dt ,(if (= num 1)
453 "One participant"
454 (string-append (number->string num)
455 " participants")))
456 (dd
457 (ul ,(map (lambda (name)
458 `(li (span (@ (class "name")))
459 ,name))
460 (map extract-name parties)))))))
461 (dl
462 (@ (class "stat"))
463 (dt "Owner")
464 (dd
465 ,(or (and=> (bug-owner bug) extract-name) "unassigned")))
466 (dl
467 (@ (class "stat"))
468 (dt "Severity")
469 (dd ,(bug-severity bug)))
470 (dl
471 (@ (class "stat"))
472 (dt "Status")
473 (dd ,(status-tag bug)))))))))
474
475 (define (list-of-bugs bugs)
476 "Return table rows for all BUGS."
477 (map (lambda (bug)
478 (let ((id (number->string (bug-num bug))))
479 `(tr (@ (class ,(bug-severity bug)))
480 (td ,(or id "-"))
481 (td ,(if id
482 `(a (@ (href ,(string-append "/issue/" id)))
483 ,(bug-subject* bug))
484 (bug-subject* bug)))
485 (td ,(date->string (bug-date bug)))
486 (td ,(status-tag bug)))))
487 bugs))
488
489 (define (priority-bugs)
490 (list-of-bugs (sort
491 (append
492 (bugs-by-severity "serious" "open")
493 (bugs-by-severity "important" "open"))
494 (lambda (a b) (< (bug-num a) (bug-num b))))))
495
496 (define (list-of-matching-bugs query bugs)
497 (layout
498 #:body
499 `(,(header)
500 (div (@ (class "container"))
501 ,@(if (null? bugs)
502 `((h1 "No issues found")
503 (p "We could not find any issues matching your query "
504 (code ,query) ". "
505 (a (@ (href "/"))
506 "Try searching for something else?")))
507 `((h1 "Submissions matching " (code ,query))
508 (table (@ (class "table table-condensed table-sm table-hover"))
509 (thead
510 (tr (th "ID")
511 (th "Subject")
512 (th "Date submitted")
513 (th "Status")))
514 (tbody
515 ,@(list-of-bugs bugs)))))))))